diff: typeclasses
David Glen JEFFERY
dgj at cs.mu.oz.au
Fri Nov 21 15:56:51 AEDT 1997
Hi all,
Well... here are the long-awaited changes to support typeclasses. I imagine
that there are a few bugs, but the compiler bootstraps, and all the tests
are passed (except valid/agc_*, which the installed compiler seems to fail
on too... Tyse?)
I am in the process of packaging up a nice test suite. It should follow in
the next few days. There is at least one failure on the tests I have, which I
will try to fix while this is being reviewed.
These changes have already been reviewed by Fergus once. I have addressed all
of his concerns except:
- I'm not yet convinced that storing the hlds_instance_defn in a
multi_map is worth the effort.
- There are still a few too many brackets required in the typeclass
decls. As you suggested, maybe pred and func should go to 800. I'll
wait for Peter to commit that change before I address this.
- The error messages are still poor, although the ones in typecheck.m
aren't too bad. (check_typeclass.m sucks dogwater bigtime, though).
Could you have another look, Fergus? In particular, the checking of
superclasses in check_typeclass.m is new, as is their handling in
polymorphism.m.
Tom, there is an XXX with your name on it in there.
Could Tyse also have a look, seeing that he seems to be Mr. Type-info. (Or is
that MR_Type_Info? Oh dear, I've been doing this for too long).
Comments from anyone are welcome. Particularly, I'd like to hear where people
find the documentation a bit thin.
Test cases and entries for the language reference manual to come RSN.
==============================================================================
Estimated hours taken: 500 or so
This change implements typeclasses. Included are the necessary changes to
the compiler, runtime and library.
compiler/typecheck.m:
Typecheck the constraints on a pred by adding constraints for each
call to a pred/func with constraints, and eliminating constraints
by applying context reduction.
While reducing the constraints, keep track of the proofs so that
polymorphism can produce the tyepclass_infos for eliminated
constraints.
compiler/polymorphism.m:
Perform the source-to-source transformation which turns code with
typeclass constraints into code without constraints, but with extra
"typeclass_info", or "dictionary" parameters.
Also, rather than always having a type_info directly for each type
variable, sometimes the type_info is hidden inside a typeclass_info.
compiler/bytecode*.m:
Insert some code to abort if bytecode generation is used when
typeclasses are used.
compiler/call_gen.m:
Generate code for a class_method_call, which forms the body of a class
method (by selecting the appropriate proc from the typeclass_info).
compiler/dead_proc_elim.m:
Don't eliminate class methods if they are potentially used outside
the module
compiler/hlds_data.m:
Define data types to store:
- the typeclass definitions
- the instances of a class
- "constraint_proof". ie. the proofs of redundancy of a
constraint. This info is used by polymorphism to construct the
typeclass_infos for a constraint.
- the "base_tyepclass_info_constant", which is analagous the
the base_type_info_constant
compiler/hlds_data.m:
Define the class_method_call goal. This goal is inserted into the
body of class method procs, and is responsible for selecting the
appropriate part of the typeclass_info to call.
compiler/hlds_data.m:
Add the class table and instance table to the module_info.
compiler/hlds_out.m:
Output info about base_typeclass_infos and class_method_calls
compiler/hlds_pred.m:
Change the representation of the locations of type_infos from "var"
to type_info_locn, which is either a var, or part of a typeclass_info,
since now the typeclass_infos contain the type_infos for the type that
they constrain.
Add constraints to the pred_info.
Add constraint_proofs to the pred_info (so that typeclass.m can
annotate the pred_info with the reasons that constraints were
eliminated, so that polymorphism.m can in turn generate the
typeclass_infos for the constraints).
Add the "class_method" marker.
compiler/lambda.m:
A feable attempt at adding class ontexts to lambda expressions,
untested and almost certainly not working.
compiler/llds_out.m:
Output the code addresses for do_*det_class_method, and output
appropriately mangled symbol names for base_typeclass_infos.
compiler/make_hlds.m:
Add constraints to the types on pred and func decls, and add
class and instance declarations to the class_table and instance_table
respectively.
compiler/mercury_compile.m:
Add the check_typeclass pass.
compiler/mercury_to_mercury.m:
Output constraints of pred and funcs, and output typeclass and instance
declarations.
compiler/module_qual.m:
Module qualify typeclass names in pred class contexts, and qualify the
typeclass and instance decls themselves.
compiler/modules.m:
Output typeclass declarations in the short interface too.
compiler/prog_data.m:
Add the "typeclass" and "instance" items. Define the types to store
information about the declarations, including class contexts on pred
and func decls.
compiler/prog_io.m:
Parse constraints on pred and func declarations.
compiler/prod_out.m:
Output class contexts on pred and func decls.
compiler/type_util.m:
Add preds to apply a substitution to a class_constraint, and to
a list of class constraints. Add type_list_matches_exactly/2. Also
add typeclass_info and base_typeclass_info as types which should not
be optimised as no_tag types (seeing that we cheat a bit about their
representation).
compiler/notes/compiler_design.html:
Add notes on module qualification of class contexts. Needs expansion
to include more stuff on typeclasses.
compiler/*.m:
Various minor changes.
compiler/base_typeclass_info.m: (New File)
Produce one base_typeclass_infos for each instance declaration.
compiler/prog_io_typeclass.m: (New File)
Parse typeclass and instance declarations.
compiler/check_typeclass.m: (New File)
Check the conformance of an instance declaration to the typeclass
declaration, including building up a proof of how superclass
constraints are satisfied so that polymorphism.m is able to construct
the typeclass_info, including the superclass typeclass_infos.
library/mercury_builtin.m:
Implement that base_typeclass_info and typeclass_info types, as
well as the predicates type_info_from_typeclass_info/3 to extract
a type_info from a typeclass_info, and superclass_from_typeclass_info/3
for extracting superclasses.
library/ops.m:
Add "typeclass" and "instance" as operators.
library/string.m:
Add a (in, uo) mode for string__length/3.
runtime/mercury_ho_call.c:
Implement do_call_*det_class_method, which are the pieces of code
responsible for extracting the correct code address from the
typeclass_info, setting up the arguments correctly, then executing
the code.
runtime/mercury_type_info.h:
Macros for accessing the typeclass_info structure.
Index: compiler/base_type_info.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/base_type_info.m,v
retrieving revision 1.12
diff -u -r1.12 base_type_info.m
--- base_type_info.m 1997/08/05 04:37:30 1.12
+++ base_type_info.m 1997/08/28 06:13:00
@@ -35,7 +35,7 @@
:- implementation.
-:- import_module prog_data, hlds_data, hlds_pred, hlds_out.
+:- import_module prog_data, hlds_data, hlds_pred, hlds_out, base_typeclass_info.
:- import_module llds, code_util, globals, special_pred, options.
:- import_module bool, string, list, map, std_util, require.
@@ -118,7 +118,10 @@
base_type_info__generate_llds(ModuleInfo, CModules) :-
module_info_base_gen_infos(ModuleInfo, BaseGenInfos),
base_type_info__construct_base_type_infos(BaseGenInfos, ModuleInfo,
- CModules).
+ CModules1),
+ base_typeclass_info__generate_llds(ModuleInfo, CModules2),
+ % XXX make this use an accumulator
+ list__append(CModules1, CModules2, CModules).
:- pred base_type_info__construct_base_type_infos(list(base_gen_info),
module_info, list(c_module)).
Index: compiler/base_type_layout.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/base_type_layout.m,v
retrieving revision 1.23
diff -u -r1.23 base_type_layout.m
--- base_type_layout.m 1997/11/08 13:11:06 1.23
+++ base_type_layout.m 1997/11/17 02:38:33
@@ -1196,7 +1196,10 @@
base_type_layout__tag_type_and_value(int_constant(_), -1, unused).
base_type_layout__tag_type_and_value(pred_closure_tag(_, _), -1, unused).
base_type_layout__tag_type_and_value(code_addr_constant(_, _), -1, unused).
-base_type_layout__tag_type_and_value(base_type_info_constant(_, _, _), -1,unused).
+base_type_layout__tag_type_and_value(base_type_info_constant(_, _, _), -1,
+ unused).
+base_type_layout__tag_type_and_value(base_typeclass_info_constant(_, _, _), -1,
+ unused).
% Get the arguments of this constructor of the current type.
Index: compiler/bytecode.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/bytecode.m,v
retrieving revision 1.29
diff -u -r1.29 bytecode.m
--- bytecode.m 1997/07/27 14:59:51 1.29
+++ bytecode.m 1997/08/26 05:06:56
@@ -82,6 +82,8 @@
arity, byte_proc_id)
; base_type_info_const(byte_module_id, string,
int)
+ ; base_typeclass_info_const(byte_module_id,
+ class_id, string)
; char_const(char)
.
@@ -727,6 +729,10 @@
{ char__to_int(Char, Byte) },
output_byte(Byte).
+ % XXX FIX THIS
+output_cons_id(base_typeclass_info_const(_, _, _)) -->
+ output_byte(8).
+
:- pred debug_cons_id(byte_cons_id, io__state, io__state).
:- mode debug_cons_id(in, di, uo) is det.
@@ -762,6 +768,15 @@
debug_module_id(ModuleId),
debug_string(TypeName),
debug_int(TypeArity).
+debug_cons_id(base_typeclass_info_const(ModuleId,
+ class_id(ClassName, ClassArity), Instance)) -->
+ debug_string("base_typeclass_info_const"),
+ debug_module_id(ModuleId),
+ debug_string("class_id"),
+ debug_sym_name(ClassName),
+ debug_string("/"),
+ debug_int(ClassArity),
+ debug_string(Instance).
debug_cons_id(char_const(Char)) -->
debug_string("char_const"),
{ string__from_char_list([Char], String) },
@@ -1265,6 +1280,18 @@
debug_float(Val) -->
io__write_float(Val),
+ io__write_char(' ').
+
+:- pred debug_sym_name(sym_name, io__state, io__state).
+:- mode debug_sym_name(in, di, uo) is det.
+
+debug_sym_name(unqualified(Val)) -->
+ io__write_string(Val),
+ io__write_char(' ').
+debug_sym_name(qualified(Module, Val)) -->
+ io__write_string(Module),
+ io__write_char(':'),
+ io__write_string(Val),
io__write_char(' ').
%---------------------------------------------------------------------------%
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.30
diff -u -r1.30 bytecode_gen.m
--- bytecode_gen.m 1997/09/01 14:00:22 1.30
+++ bytecode_gen.m 1997/09/08 04:11:51
@@ -161,6 +161,10 @@
ArgTypes, ArgModes, Detism, ByteInfo0, Code),
ByteInfo = ByteInfo0
;
+ % XXX
+ GoalExpr = class_method_call(_, _, _, _, _, _),
+ error("sorry: bytecode not implemented yet for typeclasses")
+ ;
GoalExpr = call(PredId, ProcId, ArgVars, BuiltinState, _, _),
( BuiltinState = not_builtin ->
goal_info_get_determinism(GoalInfo, Detism),
@@ -618,6 +622,11 @@
ConsId = base_type_info_const(ModuleName, TypeName, TypeArity),
ByteConsId = base_type_info_const(ModuleName, TypeName,
TypeArity)
+ ;
+ ConsId = base_typeclass_info_const(ModuleName, ClassId,
+ Instance),
+ ByteConsId = base_typeclass_info_const(ModuleName, ClassId,
+ Instance)
).
:- pred bytecode_gen__map_cons_tag(cons_tag::in, byte_cons_tag::out) is det.
@@ -639,6 +648,8 @@
error("code_addr_constant cons tag for non-address_const cons id").
bytecode_gen__map_cons_tag(base_type_info_constant(_, _, _), _) :-
error("base_type_info_constant cons tag for non-base_type_info_constant cons id").
+bytecode_gen__map_cons_tag(base_typeclass_info_constant(_, _, _), _) :-
+ error("base_typeclass_info_constant cons tag for non-base_typeclass_info_constant cons id").
%---------------------------------------------------------------------------%
Index: compiler/call_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/call_gen.m,v
retrieving revision 1.114
diff -u -r1.114 call_gen.m
--- call_gen.m 1997/10/03 04:55:25 1.114
+++ call_gen.m 1997/10/14 07:12:10
@@ -27,6 +27,12 @@
:- mode call_gen__generate_higher_order_call(in, in, in, in, in, in, in, out,
in, out) is det.
+:- pred call_gen__generate_class_method_call(code_model, var, int, list(var),
+ list(type), list(mode), determinism, hlds_goal_info,
+ code_tree, code_info, code_info).
+:- mode call_gen__generate_class_method_call(in, in, in, in, in, in, in, in,
+ out, in, out) is det.
+
:- pred call_gen__generate_call(code_model, pred_id, proc_id, list(var),
hlds_goal_info, code_tree, code_info, code_info).
:- mode call_gen__generate_call(in, in, in, in, in, out, in, out) is det.
@@ -252,6 +258,139 @@
tree(TraceCode,
tree(CallCode,
FailHandlingCode))))))))
+ }.
+
+%---------------------------------------------------------------------------%
+
+ %
+ % for a class method call,
+ % we split the arguments into inputs and outputs, put the inputs
+ % in the locations expected by do_call_<detism>_class_method in
+ % runtime/call.mod, generate the call to do_call_<detism>_class_method,
+ % and pick up the outputs from the locations that we know
+ % runtime/call.mod leaves them in.
+ %
+call_gen__generate_class_method_call(_OuterCodeModel, TCVar, Num, Args, Types,
+ Modes, Det, GoalInfo, Code) -->
+ { determinism_to_code_model(Det, InnerCodeModel) },
+ code_info__get_globals(Globals),
+ code_info__get_module_info(ModuleInfo),
+ { globals__get_args_method(Globals, ArgsMethod) },
+ { make_arg_infos(ArgsMethod, Types, Modes, InnerCodeModel, ModuleInfo,
+ ArgInfo) },
+ { assoc_list__from_corresponding_lists(Args, ArgInfo, ArgsAndArgInfo) },
+ { call_gen__partition_args(ArgsAndArgInfo, InVars, OutVars) },
+ call_gen__generate_class_method_call2(InnerCodeModel, TCVar, Num,
+ InVars, OutVars, GoalInfo, Code).
+
+ % XXX This assumes compact args!!!
+ % XXX This assumes compact args!!!
+ % XXX This assumes compact args!!!
+:- pred call_gen__generate_class_method_call2(code_model, var, int, list(var),
+ list(var), hlds_goal_info, code_tree, code_info, code_info).
+:- mode call_gen__generate_class_method_call2(in, in, in, in, in, in, out, in,
+ out) is det.
+
+call_gen__generate_class_method_call2(CodeModel, TCVar, Index, InVars, OutVars,
+ GoalInfo, Code) -->
+ code_info__succip_is_used,
+ { set__list_to_set(OutVars, OutArgs) },
+ call_gen__save_variables(OutArgs, SaveCode),
+ (
+ { CodeModel = model_det },
+ { CallModel = det },
+ { RuntimeAddr = do_det_class_method },
+ { FlushCode = empty }
+ ;
+ { CodeModel = model_semi },
+ { CallModel = semidet },
+ { RuntimeAddr = do_semidet_class_method },
+ { FlushCode = empty }
+ ;
+ { CodeModel = model_non },
+ code_info__may_use_nondet_tailcall(TailCall),
+ { CallModel = nondet(TailCall) },
+ { RuntimeAddr = do_nondet_class_method },
+ code_info__unset_failure_cont(FlushCode)
+ ),
+ % place the immediate input arguments in registers
+ % starting at r5.
+ call_gen__generate_immediate_args(InVars, 5, InLocs, ImmediateCode),
+ code_info__generate_stack_livevals(OutArgs, LiveVals0),
+ { set__insert_list(LiveVals0,
+ [reg(r, 1), reg(r, 2), reg(r, 3), reg(r, 4) | InLocs],
+ LiveVals) },
+ (
+ { CodeModel = model_semi }
+ ->
+ { FirstArg = 2 }
+ ;
+ { FirstArg = 1 }
+ ),
+ { call_gen__outvars_to_outargs(OutVars, FirstArg, OutArguments) },
+ { call_gen__output_arg_locs(OutArguments, OutLocs) },
+
+ code_info__get_instmap(InstMap),
+ { goal_info_get_instmap_delta(GoalInfo, InstMapDelta) },
+ { instmap__apply_instmap_delta(InstMap, InstMapDelta,
+ AfterCallInstMap) },
+
+ call_gen__generate_return_livevals(OutArgs, OutLocs, AfterCallInstMap,
+ OutLiveVals),
+ code_info__produce_variable(TCVar, TCVarCode, TCVarRVal),
+ (
+ { TCVarRVal = lval(reg(r, 1)) }
+ ->
+ { CopyCode = empty }
+ ;
+ { CopyCode = node([
+ assign(reg(r, 1), TCVarRVal) - "Copy typeclass info"
+ ])}
+ ),
+ { list__length(InVars, NInVars) },
+ { list__length(OutVars, NOutVars) },
+ { SetupCode = tree(CopyCode, node([
+ assign(reg(r, 2), const(int_const(Index))) -
+ "Index of class method in typeclass info",
+ assign(reg(r, 3), const(int_const(NInVars))) -
+ "Assign number of immediate input arguments",
+ assign(reg(r, 4), const(int_const(NOutVars))) -
+ "Assign number of output arguments"
+ ])
+ ) },
+ code_info__get_next_label(ReturnLabel),
+ { TryCallCode = node([
+ livevals(LiveVals) - "",
+ call(RuntimeAddr, label(ReturnLabel), OutLiveVals, CallModel)
+ - "setup and call class method",
+ label(ReturnLabel) - "Continuation label"
+ ]) },
+ call_gen__rebuild_registers(OutArguments),
+ (
+ { CodeModel = model_semi }
+ ->
+ code_info__generate_failure(FailCode),
+ code_info__get_next_label(ContLab),
+ { TestSuccessCode = node([
+ if_val(lval(reg(r, 1)), label(ContLab)) -
+ "Test for success"
+ ]) },
+ { ContLabelCode = node([label(ContLab) - ""]) },
+ { CallCode =
+ tree(TryCallCode,
+ tree(TestSuccessCode,
+ tree(FailCode,
+ ContLabelCode))) }
+ ;
+ { CallCode = TryCallCode }
+ ),
+ { Code =
+ tree(SaveCode,
+ tree(FlushCode,
+ tree(ImmediateCode,
+ tree(TCVarCode,
+ tree(SetupCode,
+ CallCode)))))
}.
%---------------------------------------------------------------------------%
Index: compiler/code_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/code_gen.m,v
retrieving revision 1.39
diff -u -r1.39 code_gen.m
--- code_gen.m 1997/11/08 13:11:09 1.39
+++ code_gen.m 1997/11/17 02:38:35
@@ -694,6 +694,11 @@
GoalInfo, Instr) -->
call_gen__generate_higher_order_call(model_det, PredVar, Args,
Types, Modes, Det, GoalInfo, Instr).
+code_gen__generate_det_goal_2(class_method_call(TCVar, Num, Args, Types,
+ Modes, Det),
+ GoalInfo, Instr) -->
+ call_gen__generate_class_method_call(model_det, TCVar, Num, Args,
+ Types, Modes, Det, GoalInfo, Instr).
code_gen__generate_det_goal_2(call(PredId, ProcId, Args, BuiltinState, _, _),
GoalInfo, Instr) -->
(
@@ -781,6 +786,10 @@
Det, _PredOrFunc), GoalInfo, Code) -->
call_gen__generate_higher_order_call(model_semi, PredVar, Args,
Types, Modes, Det, GoalInfo, Code).
+code_gen__generate_semi_goal_2(class_method_call(TCVar, Num, Args, Types, Modes,
+ Det), GoalInfo, Code) -->
+ call_gen__generate_class_method_call(model_semi, TCVar, Num, Args,
+ Types, Modes, Det, GoalInfo, Code).
code_gen__generate_semi_goal_2(call(PredId, ProcId, Args, BuiltinState, _, _),
GoalInfo, Code) -->
(
@@ -981,6 +990,11 @@
Det, _PredOrFunc),
GoalInfo, Code) -->
call_gen__generate_higher_order_call(model_non, PredVar, Args, Types,
+ Modes, Det, GoalInfo, Code).
+code_gen__generate_non_goal_2(class_method_call(TCVar, Num, Args, Types, Modes,
+ Det),
+ GoalInfo, Code) -->
+ call_gen__generate_class_method_call(model_non, TCVar, Num, Args, Types,
Modes, Det, GoalInfo, Code).
code_gen__generate_non_goal_2(call(PredId, ProcId, Args, BuiltinState, _, _),
GoalInfo, Code) -->
Index: compiler/code_info.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/code_info.m,v
retrieving revision 1.213
diff -u -r1.213 code_info.m
--- code_info.m 1997/10/03 04:55:31 1.213
+++ code_info.m 1997/11/20 07:16:32
@@ -651,7 +651,7 @@
:- mode code_info__lookup_type_defn(in, out, in, out) is det.
% Given a list of type variables, find the lvals where the
- % corresponding type_infos are being stored.
+ % corresponding type_infos and typeclass_infos are being stored.
:- pred code_info__find_type_infos(list(var), assoc_list(var, lval),
code_info, code_info).
:- mode code_info__find_type_infos(in, out, in, out) is det.
@@ -836,13 +836,13 @@
code_info__find_type_infos([TVar | TVars], [TVar - Lval | Lvals]) -->
code_info__get_proc_info(ProcInfo),
{ proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap) },
- (
- { map__search(TypeInfoMap, TVar, Var0) }
+ {
+ map__search(TypeInfoMap, TVar, Locn)
->
- { Var = Var0 }
+ type_info_locn_var(Locn, Var)
;
- { error("cannot find var for type variable") }
- ),
+ error("cannot find var for type variable")
+ },
{ proc_info_stack_slots(ProcInfo, StackSlots) },
(
{ map__search(StackSlots, Var, Lval0) }
Index: compiler/code_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/code_util.m,v
retrieving revision 1.89
diff -u -r1.89 code_util.m
--- code_util.m 1997/09/01 14:00:37 1.89
+++ code_util.m 1997/09/08 04:20:45
@@ -644,6 +644,8 @@
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), _, _,
+ base_typeclass_info_constant(M,C,N)).
code_util__cons_id_to_tag(cons(Name, Arity), Type, ModuleInfo, Tag) :-
(
% handle the `character' type specially
@@ -771,6 +773,8 @@
code_util__count_recursive_calls_2(unify(_, _, _, _, _), _, _, 0, 0).
code_util__count_recursive_calls_2(higher_order_call(_, _,_, _, _, _), _, _,
0, 0).
+code_util__count_recursive_calls_2(class_method_call(_, _,_, _, _, _), _, _,
+ 0, 0).
code_util__count_recursive_calls_2(pragma_c_code(_,_,_,_, _, _, _, _), _, _,
0, 0).
code_util__count_recursive_calls_2(call(CallPredId, CallProcId, _, _, _, _),
Index: compiler/constraint.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/constraint.m,v
retrieving revision 1.35
diff -u -r1.35 constraint.m
--- constraint.m 1997/09/01 14:00:47 1.35
+++ constraint.m 1997/09/08 04:12:00
@@ -179,6 +179,12 @@
mode_checkpoint(exit, "higher-order call").
constraint__propagate_goal_2(
+ class_method_call(A, B, C, D, E, F),
+ class_method_call(A, B, C, D, E, F)) -->
+ mode_checkpoint(enter, "class method call"),
+ mode_checkpoint(exit, "class method call").
+
+constraint__propagate_goal_2(
call(PredId, ProcId, ArgVars, Builtin, Sym, Context),
call(PredId, ProcId, ArgVars, Builtin, Sym, Context)) -->
mode_checkpoint(enter, "call"),
Index: compiler/cse_detection.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/cse_detection.m,v
retrieving revision 1.48
diff -u -r1.48 cse_detection.m
--- cse_detection.m 1997/09/01 14:00:51 1.48
+++ cse_detection.m 1997/09/08 04:22:09
@@ -206,6 +206,9 @@
detect_cse_in_goal_2(higher_order_call(A,B,C,D,E,F), _, _, CseInfo, CseInfo,
no, higher_order_call(A,B,C,D,E,F)).
+detect_cse_in_goal_2(class_method_call(A,B,C,D,E,F), _, _, CseInfo, CseInfo,
+ no, class_method_call(A,B,C,D,E,F)).
+
detect_cse_in_goal_2(call(A,B,C,D,E,F), _, _, CseInfo, CseInfo, no,
call(A,B,C,D,E,F)).
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.32
diff -u -r1.32 dead_proc_elim.m
--- dead_proc_elim.m 1997/09/01 14:00:56 1.32
+++ dead_proc_elim.m 1997/11/03 05:43:31
@@ -110,7 +110,10 @@
Queue1, Queue2, Needed1, Needed2),
module_info_base_gen_infos(ModuleInfo, BaseGenInfos),
dead_proc_elim__initialize_base_gen_infos(BaseGenInfos,
- Queue2, Queue, Needed2, Needed).
+ Queue2, Queue3, Needed2, Needed3),
+ module_info_instances(ModuleInfo, Instances),
+ dead_proc_elim__initialize_class_methods(Instances,
+ Queue3, Queue, Needed3, Needed).
% Add all normally exported procedures within the listed predicates
% to the queue and map.
@@ -198,6 +201,62 @@
dead_proc_elim__initialize_base_gen_infos(BaseGenInfos,
Queue1, Queue, Needed1, Needed).
+:- pred dead_proc_elim__initialize_class_methods(instance_table,
+ entity_queue, entity_queue, needed_map, needed_map).
+:- mode dead_proc_elim__initialize_class_methods(in, in, out, in, out) is det.
+
+dead_proc_elim__initialize_class_methods(Instances, Queue0, Queue,
+ Needed0, Needed) :-
+ map__values(Instances, InstanceDefns0),
+ list__condense(InstanceDefns0, InstanceDefns),
+ list__foldl2(get_instance_pred_procs, InstanceDefns, Queue0, Queue,
+ Needed0, Needed).
+
+:- pred get_instance_pred_procs(hlds_instance_defn, entity_queue, entity_queue,
+ needed_map, needed_map).
+:- mode get_instance_pred_procs(in, in, out, in, out) is det.
+
+get_instance_pred_procs(Instance, Queue0, Queue, Needed0, Needed) :-
+ Instance = hlds_instance_defn(ImportStatus, _, _, _, PredProcIds, _, _),
+ (
+ % We only need the instance declarations which were
+ % made in this module.
+ ( ImportStatus = exported
+ ; ImportStatus = abstract_exported
+ ; ImportStatus = pseudo_exported
+ ; ImportStatus = local
+ )
+ ->
+ get_instance_pred_procs2(PredProcIds, Queue0, Queue,
+ Needed0, Needed)
+ ;
+ Queue = Queue0,
+ Needed = Needed0
+ ).
+
+:- pred get_instance_pred_procs2(maybe(list(hlds_class_proc)),
+ entity_queue, entity_queue, needed_map, needed_map).
+:- mode get_instance_pred_procs2(in, in, out, in, out) is det.
+
+get_instance_pred_procs2(PredProcIds, Queue0, Queue, Needed0, Needed) :-
+ (
+ % This should never happen
+ PredProcIds = no,
+ Queue = Queue0,
+ Needed = Needed0
+ ;
+ PredProcIds = yes(Ids),
+ AddHldsClassProc = lambda(
+ [PredProc::in, Q0::in, Q::out, N0::in, N::out] is det,
+ (
+ PredProc = hlds_class_proc(PredId, ProcId),
+ queue__put(Q0, proc(PredId, ProcId), Q),
+ map__set(N0, proc(PredId, ProcId), no, N)
+ )),
+ list__foldl2(AddHldsClassProc, Ids, Queue0, Queue,
+ Needed0, Needed)
+ ).
+
%-----------------------------------------------------------------------------%
:- pred dead_proc_elim__examine(entity_queue, examined_set, module_info,
@@ -372,6 +431,8 @@
Needed2, Needed).
dead_proc_elim__examine_expr(higher_order_call(_,_,_,_,_,_), _,
Queue, Queue, Needed, Needed).
+dead_proc_elim__examine_expr(class_method_call(_,_,_,_,_,_), _,
+ Queue, Queue, Needed, Needed).
dead_proc_elim__examine_expr(call(PredId, ProcId, _,_,_,_),
CurrProc, Queue0, Queue, Needed0, Needed) :-
queue__put(Queue0, proc(PredId, ProcId), Queue),
@@ -693,6 +754,7 @@
)) },
list__foldl(ExamineCase, Cases).
pre_modecheck_examine_goal(higher_order_call(_,_,_,_,_,_) - _) --> [].
+pre_modecheck_examine_goal(class_method_call(_,_,_,_,_,_) - _) --> [].
pre_modecheck_examine_goal(not(Goal) - _) -->
pre_modecheck_examine_goal(Goal).
pre_modecheck_examine_goal(some(_, Goal) - _) -->
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dependency_graph.m,v
retrieving revision 1.30
diff -u -r1.30 dependency_graph.m
--- dependency_graph.m 1997/09/01 14:00:59 1.30
+++ dependency_graph.m 1997/09/08 04:26:58
@@ -218,6 +218,8 @@
dependency_graph__add_arcs_in_goal_2(higher_order_call(_, _, _, _, _, _),
_Caller, DepGraph, DepGraph).
+dependency_graph__add_arcs_in_goal_2(class_method_call(_, _, _, _, _, _),
+ _Caller, DepGraph, DepGraph).
dependency_graph__add_arcs_in_goal_2(call(PredId, ProcId, _, Builtin, _, _),
Caller, DepGraph0, DepGraph) :-
@@ -321,6 +323,8 @@
DepGraph = DepGraph0
).
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).
%-----------------------------------------------------------------------------%
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/det_analysis.m,v
retrieving revision 1.124
diff -u -r1.124 det_analysis.m
--- det_analysis.m 1997/11/17 05:47:30 1.124
+++ det_analysis.m 1997/11/21 00:18:40
@@ -454,7 +454,29 @@
NumSolns = at_most_many_cc,
SolnContext \= first_soln
->
- Msgs = [higher_order_cc_pred_in_wrong_context(GoalInfo, Det)],
+ Msgs = [higher_order_cc_pred_in_wrong_context(GoalInfo, Det0)],
+ % Code elsewhere relies on the assumption that
+ % SolnContext \= first_soln => NumSolns \= at_most_many_cc,
+ % so we need to enforce that here.
+ determinism_components(Det, CanFail, at_most_many)
+ ;
+ Msgs = [],
+ Det = Det0
+ ).
+
+det_infer_goal_2(class_method_call(TCVar, Num, ArgVars, Types, Modes, Det0),
+ GoalInfo, _InstMap0, SolnContext,
+ _MiscInfo, _NonLocalVars, _DeltaInstMap,
+ class_method_call(TCVar, Num, ArgVars, Types, Modes, Det0),
+ Det, Msgs) :-
+ determinism_components(Det0, CanFail, NumSolns),
+ (
+ NumSolns = at_most_many_cc,
+ SolnContext \= first_soln
+ ->
+ % XXX this will give a slightly misleading error
+ % XXX message
+ Msgs = [higher_order_cc_pred_in_wrong_context(GoalInfo, Det0)],
% Code elsewhere relies on the assumption that
% SolnContext \= first_soln => NumSolns \= at_most_many_cc,
% so we need to enforce that here.
@@ -972,7 +994,8 @@
segregate_procs(ModuleInfo, PredProcs, DeclaredProcs, UndeclaredProcs).
% get_all_pred_procs takes a module_info and returns a list
- % of all the procedures ids for that module.
+ % of all the procedures ids for that module (except class methods,
+ % which do not need to be checked since we generate the code ourselves).
:- pred get_all_pred_procs(module_info, pred_proc_list).
:- mode get_all_pred_procs(in, out) is det.
@@ -989,8 +1012,16 @@
get_all_pred_procs_2(_Preds, [], PredProcs, PredProcs).
get_all_pred_procs_2(Preds, [PredId|PredIds], PredProcs0, PredProcs) :-
map__lookup(Preds, PredId, Pred),
- pred_info_non_imported_procids(Pred, ProcIds),
- fold_pred_modes(PredId, ProcIds, PredProcs0, PredProcs1),
+ pred_info_get_marker_list(Pred, Markers),
+ (
+ % ignore class members
+ list__member(request(class_method), Markers)
+ ->
+ PredProcs1 = PredProcs0
+ ;
+ pred_info_non_imported_procids(Pred, ProcIds),
+ fold_pred_modes(PredId, ProcIds, PredProcs0, PredProcs1)
+ ),
get_all_pred_procs_2(Preds, PredIds, PredProcs1, PredProcs).
:- pred fold_pred_modes(pred_id, list(proc_id), pred_proc_list, pred_proc_list).
Index: compiler/det_report.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/det_report.m,v
retrieving revision 1.43
diff -u -r1.43 det_report.m
--- det_report.m 1997/11/17 05:47:33 1.43
+++ det_report.m 1997/11/20 23:40:22
@@ -463,6 +463,17 @@
det_diagnose_atomic_goal(Desired, Actual,
report_higher_order_call_context(Context), Context).
+ % There's probably no point in this code being here: we only
+ % insert class_method_calls by hand, so they're gauranteed to be right,
+ % and in any case, we insert them after determinism analysis.
+ % Nonetheless, it's probably safer to include the code.
+det_diagnose_goal_2(class_method_call(_, _, _, _, _, _), GoalInfo,
+ Desired, Actual, _, _MiscInfo, yes) -->
+ { goal_info_get_context(GoalInfo, Context) },
+ prog_out__write_context(Context),
+ det_diagnose_atomic_goal(Desired, Actual,
+ report_higher_order_call_context(Context), Context).
+
det_diagnose_goal_2(unify(LT, RT, _, _, UnifyContext), GoalInfo,
Desired, Actual, _, DetInfo, yes) -->
{ goal_info_get_context(GoalInfo, Context) },
Index: compiler/dnf.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dnf.m,v
retrieving revision 1.23
diff -u -r1.23 dnf.m
--- dnf.m 1997/10/31 00:14:22 1.23
+++ dnf.m 1997/11/17 06:32:40
@@ -220,6 +220,11 @@
NewPredIds = NewPredIds0,
Goal = Goal0
;
+ GoalExpr0 = class_method_call(_, _, _, _, _, _),
+ ModuleInfo = ModuleInfo0,
+ NewPredIds = NewPredIds0,
+ Goal = Goal0
+ ;
GoalExpr0 = call(_, _, _, _, _, _),
ModuleInfo = ModuleInfo0,
NewPredIds = NewPredIds0,
@@ -377,8 +382,14 @@
Goal0 = _GoalExpr - GoalInfo,
goal_info_get_nonlocals(GoalInfo, NonLocals),
set__to_sorted_list(NonLocals, ArgVars),
+ % XXX
+ % XXX Does this new pred necessarily have an empty context?
+ % XXX I would think not. The pred context should probably be
+ % XXX added to the dnf_info.
+ % XXX
+ ClassContext = [],
hlds_pred__define_new_pred(Goal0, Goal, ArgVars, InstMap0, PredName,
- TVarSet, VarTypes, VarSet, Markers,
+ TVarSet, VarTypes, ClassContext, VarSet, Markers,
ModuleInfo0, ModuleInfo, PredProcId),
PredProcId = proc(PredId, _).
@@ -422,6 +433,7 @@
dnf__is_atomic_expr(conj(_), no).
dnf__is_atomic_expr(higher_order_call(_, _, _, _, _, _), yes).
+dnf__is_atomic_expr(class_method_call(_, _, _, _, _, _), yes).
dnf__is_atomic_expr(call(_, _, _, _, _, _), yes).
dnf__is_atomic_expr(switch(_, _, _, _), no).
dnf__is_atomic_expr(unify(_, _, _, _, _), yes).
Index: compiler/dupelim.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dupelim.m,v
retrieving revision 1.24
diff -u -r1.24 dupelim.m
--- dupelim.m 1997/11/08 13:11:14 1.24
+++ dupelim.m 1997/11/17 02:38:42
@@ -285,6 +285,11 @@
dupelim__replace_labels_code_addr(do_det_closure, _, do_det_closure).
dupelim__replace_labels_code_addr(do_semidet_closure, _, do_semidet_closure).
dupelim__replace_labels_code_addr(do_nondet_closure, _, do_nondet_closure).
+dupelim__replace_labels_code_addr(do_det_class_method, _, do_det_class_method).
+dupelim__replace_labels_code_addr(do_semidet_class_method, _,
+ do_semidet_class_method).
+dupelim__replace_labels_code_addr(do_nondet_class_method, _,
+ do_nondet_class_method).
dupelim__replace_labels_code_addr(do_not_reached, _, do_not_reached).
:- pred dupelim__replace_labels_label_list(list(label), map(label, label),
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/equiv_type.m,v
retrieving revision 1.9
diff -u -r1.9 equiv_type.m
--- equiv_type.m 1997/08/22 13:54:55 1.9
+++ equiv_type.m 1997/09/08 04:12:11
@@ -112,18 +112,22 @@
equiv_type__replace_in_type_defn(TypeDefn0, VarSet0, EqvMap,
TypeDefn, VarSet, ContainsCirc).
-equiv_type__replace_in_item(pred(VarSet0, PredName, TypesAndModes0, Det, Cond),
- EqvMap, pred(VarSet, PredName, TypesAndModes, Det, Cond), no) :-
+equiv_type__replace_in_item(
+ pred(VarSet0, PredName, TypesAndModes0,
+ Det, Cond, ClassContext),
+ EqvMap,
+ pred(VarSet, PredName, TypesAndModes, Det, Cond, ClassContext),
+ no) :-
equiv_type__replace_in_tms(TypesAndModes0, VarSet0, EqvMap,
TypesAndModes, VarSet).
equiv_type__replace_in_item(
- func(VarSet0, PredName, TypesAndModes0,
- RetTypeAndMode0, Det, Cond),
- EqvMap,
- func(VarSet, PredName, TypesAndModes, RetTypeAndMode,
- Det, Cond),
- no) :-
+ func(VarSet0, PredName, TypesAndModes0,
+ RetTypeAndMode0, Det, Cond, ClassContext),
+ EqvMap,
+ func(VarSet, PredName, TypesAndModes, RetTypeAndMode,
+ Det, Cond, ClassContext),
+ no) :-
equiv_type__replace_in_tms(TypesAndModes0, VarSet0, EqvMap,
TypesAndModes, VarSet1),
equiv_type__replace_in_tm(RetTypeAndMode0, VarSet1, EqvMap,
Index: compiler/excess.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/excess.m,v
retrieving revision 1.24
diff -u -r1.24 excess.m
--- excess.m 1997/09/01 14:01:24 1.24
+++ excess.m 1997/09/08 04:47:04
@@ -120,6 +120,10 @@
Goal = GoalExpr0 - GoalInfo0,
ElimVars = ElimVars0
;
+ GoalExpr0 = class_method_call(_, _, _, _, _, _),
+ Goal = GoalExpr0 - GoalInfo0,
+ ElimVars = ElimVars0
+ ;
GoalExpr0 = call(_, _, _, _, _, _),
Goal = GoalExpr0 - GoalInfo0,
ElimVars = ElimVars0
Index: compiler/exprn_aux.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/exprn_aux.m,v
retrieving revision 1.23
diff -u -r1.23 exprn_aux.m
--- exprn_aux.m 1997/11/08 13:11:19 1.23
+++ exprn_aux.m 1997/11/17 02:38:45
@@ -150,6 +150,9 @@
exprn_aux__addr_is_constant(do_det_closure, _, no).
exprn_aux__addr_is_constant(do_semidet_closure, _, no).
exprn_aux__addr_is_constant(do_nondet_closure, _, no).
+exprn_aux__addr_is_constant(do_det_class_method, _, no).
+exprn_aux__addr_is_constant(do_semidet_class_method, _, no).
+exprn_aux__addr_is_constant(do_nondet_class_method, _, no).
exprn_aux__addr_is_constant(do_not_reached, _, no).
:- pred exprn_aux__label_is_constant(label, bool, bool, bool).
Index: compiler/follow_code.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/follow_code.m,v
retrieving revision 1.43
diff -u -r1.43 follow_code.m
--- follow_code.m 1997/09/01 14:01:28 1.43
+++ follow_code.m 1997/09/08 04:47:26
@@ -110,6 +110,9 @@
move_follow_code_in_goal_2(higher_order_call(A,B,C,D,E,F),
higher_order_call(A,B,C,D,E,F), _, R, R).
+move_follow_code_in_goal_2(class_method_call(A,B,C,D,E,F),
+ class_method_call(A,B,C,D,E,F), _, R, R).
+
move_follow_code_in_goal_2(call(A,B,C,D,E,F), call(A,B,C,D,E,F), _, R, R).
move_follow_code_in_goal_2(unify(A,B,C,D,E), unify(A,B,C,D,E), _, R, R).
Index: compiler/follow_vars.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/follow_vars.m,v
retrieving revision 1.43
diff -u -r1.43 follow_vars.m
--- follow_vars.m 1997/09/01 14:01:32 1.43
+++ follow_vars.m 1997/10/13 03:40:54
@@ -155,12 +155,30 @@
find_follow_vars_in_goal(Goal0, ArgsMethod, ModuleInfo, FollowVars0,
Goal, FollowVars).
+ % XXX These follow-vars aren't correct since the desired positions for
+ % XXX the arguments are different from an ordinary call --- they are
+ % XXX as required by do_call_{det,semidet,nondet}_closure
find_follow_vars_in_goal_2(
higher_order_call(PredVar, Args, Types, Modes, Det,
IsPredOrFunc),
ArgsMethod, ModuleInfo, _FollowVars0,
higher_order_call(PredVar, Args, Types, Modes, Det,
IsPredOrFunc),
+ FollowVars) :-
+ determinism_to_code_model(Det, CodeModel),
+ make_arg_infos(ArgsMethod, Types, Modes, CodeModel, ModuleInfo,
+ ArgInfo),
+ find_follow_vars_from_arginfo(ArgInfo, Args, FollowVars).
+
+ % XXX These follow-vars aren't correct since the desired positions for
+ % XXX the arguments are different from an ordinary call --- they are
+ % XXX as required by do_call_{det,semidet,nondet}_class_method
+find_follow_vars_in_goal_2(
+ class_method_call(TypeClassInfoVar, Num, Args, Types, Modes,
+ Det),
+ ArgsMethod, ModuleInfo, _FollowVars0,
+ class_method_call(TypeClassInfoVar, Num, Args, Types, Modes,
+ Det),
FollowVars) :-
determinism_to_code_model(Det, CodeModel),
make_arg_infos(ArgsMethod, Types, Modes, CodeModel, ModuleInfo,
Index: compiler/goal_path.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/goal_path.m,v
retrieving revision 1.1
diff -u -r1.1 goal_path.m
--- goal_path.m 1997/10/13 08:09:39 1.1
+++ goal_path.m 1997/10/17 05:10:07
@@ -56,6 +56,8 @@
fill_expr_slots(call(A,B,C,D,E,F), _Path0, call(A,B,C,D,E,F)).
fill_expr_slots(higher_order_call(A,B,C,D,E,F), _Path0,
higher_order_call(A,B,C,D,E,F)).
+fill_expr_slots(class_method_call(A,B,C,D,E,F), _Path0,
+ class_method_call(A,B,C,D,E,F)).
fill_expr_slots(unify(A,B,C,D,E), _Path0, unify(A,B,C,D,E)).
fill_expr_slots(pragma_c_code(A,B,C,D,E,F,G,H), _Path0,
pragma_c_code(A,B,C,D,E,F,G,H)).
Index: compiler/goal_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/goal_util.m,v
retrieving revision 1.38
diff -u -r1.38 goal_util.m
--- goal_util.m 1997/09/01 14:01:36 1.38
+++ goal_util.m 1997/09/08 04:50:08
@@ -226,6 +226,15 @@
goal_util__rename_var_list(Args0, Must, Subn, Args).
goal_util__name_apart_2(
+ class_method_call(TypeClassInfoVar0, Num, Args0, Types, Modes,
+ Det),
+ Must, Subn,
+ class_method_call(TypeClassInfoVar, Num, Args, Types, Modes,
+ Det)) :-
+ goal_util__rename_var(TypeClassInfoVar0, Must, Subn, TypeClassInfoVar),
+ goal_util__rename_var_list(Args0, Must, Subn, Args).
+
+goal_util__name_apart_2(
call(PredId, ProcId, Args0, Builtin, Context, Sym),
Must, Subn,
call(PredId, ProcId, Args, Builtin, Context, Sym)) :-
@@ -418,6 +427,10 @@
Set0, Set) :-
set__insert_list(Set0, [PredVar | ArgVars], Set).
+goal_util__goal_vars_2(class_method_call(PredVar, _, ArgVars, _, _, _),
+ Set0, Set) :-
+ set__insert_list(Set0, [PredVar | ArgVars], Set).
+
goal_util__goal_vars_2(call(_, _, ArgVars, _, _, _), Set0, Set) :-
set__insert_list(Set0, ArgVars, Set).
@@ -537,6 +550,7 @@
Size is Size1 + 1.
goal_expr_size(call(_, _, _, _, _, _), 1).
goal_expr_size(higher_order_call(_, _, _, _, _, _), 1).
+goal_expr_size(class_method_call(_, _, _, _, _, _), 1).
goal_expr_size(unify(_, _, _, _, _), 1).
goal_expr_size(pragma_c_code(_, _, _, _, _, _, _, _), 1).
Index: compiler/higher_order.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/higher_order.m,v
retrieving revision 1.33
diff -u -r1.33 higher_order.m
--- higher_order.m 1997/09/01 14:01:46 1.33
+++ higher_order.m 1997/10/13 03:47:44
@@ -295,6 +295,10 @@
{ Goal0 = higher_order_call(_,_,_,_,_,_) - _ },
maybe_specialize_higher_order_call(Goal0, Goal, PredProcId, Changed).
+ % For now, we do not specialize class method calls
+traverse_goal(Goal, Goal, _, unchanged, 1) -->
+ { Goal = class_method_call(_,_,_,_,_,_) - _ }.
+
% check whether this call could be specialized
traverse_goal(Goal0, Goal, PredProcId, Changed, 1) -->
{ Goal0 = call(_,_,_,_,_,_) - _ },
@@ -844,14 +848,19 @@
Name = qualified(PredModule, PredName),
varset__init(EmptyVarSet),
map__init(EmptyVarTypes),
+ map__init(EmptyProofs),
% This isn't looked at after here, and just clutters up
% hlds dumps if it's filled in.
ClausesInfo = clauses_info(EmptyVarSet, EmptyVarTypes,
EmptyVarTypes, [], []),
+ % XXX
+ % XXX This is not, in general, correct.
+ % XXX
+ TypeConstraints = [],
pred_info_init(PredModule, Name, Arity, Tvars,
Types, true, Context, ClausesInfo, local, MarkerList, GoalType,
- PredOrFunc, PredInfo1),
+ PredOrFunc, TypeConstraints, EmptyProofs, PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVars, PredInfo2),
pred_info_procedures(PredInfo2, Procs0),
next_mode_id(Procs0, no, NewProcId),
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_data.m,v
retrieving revision 1.18
diff -u -r1.18 hlds_data.m
--- hlds_data.m 1997/09/14 09:24:23 1.18
+++ hlds_data.m 1997/11/03 05:51:16
@@ -34,8 +34,15 @@
% Used for constructing type_infos.
% Note that a pred_const is for a closure
% whereas a code_addr_const is just an address.
- ; base_type_info_const(string, string, int).
+ ; base_type_info_const(string, string, int)
% module name, type name, type arity
+ ; base_typeclass_info_const(string, class_id,
+ 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
+ .
% A cons_defn is the definition of a constructor (i.e. a constant
% or a functor) for a particular type.
@@ -112,6 +119,8 @@
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(_, _, _), _) :-
+ 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)).
make_functor_cons_id(term__integer(Int), _, int_const(Int)).
@@ -241,6 +250,14 @@
% the name of the module the type is defined in
% and the name of the type, while the integer is
% the arity.
+ ; base_typeclass_info_constant(string, class_id, string)
+ % This is how we refer to base_typeclass_info structures
+ % represented as global data. The first argument is the
+ % name of the module containing the instance declration,
+ % the second is the class name and arity, while the
+ % third is the string which uniquely identifies the
+ % instance declaration (it is made from the type of
+ % the arguments to the instance decl).
; simple_tag(tag_bits)
% This is for constants or functors which only
% require a simple tag. (A "simple" tag is one
@@ -674,5 +691,64 @@
determinism_to_code_model(cc_multidet, model_det).
determinism_to_code_model(erroneous, model_det).
determinism_to_code_model(failure, model_semi).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- interface.
+
+:- type class_table == map(class_id, hlds_class_defn).
+
+:- type class_id ---> class_id(sym_name, arity).
+
+ % Information about a single `typeclass' declaration
+:- type hlds_class_defn
+ ---> hlds_class_defn(
+ list(class_constraint), % SuperClasses
+ list(var), % ClassVars
+ hlds_class_interface, % Methods
+ varset % VarNames
+ ).
+
+:- type hlds_class_interface == list(hlds_class_proc).
+:- type hlds_class_proc
+ ---> hlds_class_proc(
+ pred_id,
+ proc_id
+ ).
+
+ % For each class, we keep track of a list of its instances, since there
+ % can be more than one instance of each class.
+:- type instance_table == map(class_id, list(hlds_instance_defn)).
+
+ % Information about a single `instance' declaration
+:- type hlds_instance_defn
+ ---> hlds_instance_defn(
+ import_status, % import status of the instance
+ % declaration
+ list(class_constraint), % Constraints
+ list(type), % ClassTypes
+ instance_interface, % Methods
+ maybe(hlds_class_interface),
+ % After check_typeclass, we
+ % will know the pred_ids and
+ % proc_ids of all the methods
+ varset, % VarNames
+ map(class_constraint, constraint_proof)
+ % "Proofs" of how to build the
+ % typeclass_infos for the
+ % superclasses of this class,
+ % for this instance
+ ).
+
+ % `Proof' of why a constraint is redundant
+:- type constraint_proof
+ % Apply the following instance rule, the second
+ % argument being the number of the instance decl.
+ ---> apply_instance(hlds_instance_defn, int)
+
+ % The constraint is redundant because of the following
+ % class's superclass declaration
+ ; superclass(class_constraint).
%-----------------------------------------------------------------------------%
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_goal.m,v
retrieving revision 1.42
diff -u -r1.42 hlds_goal.m
--- hlds_goal.m 1997/10/13 08:09:41 1.42
+++ hlds_goal.m 1997/10/14 06:59:20
@@ -56,6 +56,16 @@
pred_or_func % call/N (pred) or apply/N (func)
)
+ ; class_method_call(
+ var, % the typeclass_info for the instance
+ int, % the number of the method to call
+ list(var), % the list of argument variables (other
+ % than this instance's typeclass_info)
+ list(type), % the types of the argument variables
+ list(mode), % the modes of the argument variables
+ determinism % the determinism of the called pred
+ )
+
% Deterministic disjunctions are converted
% into switches by the switch detection pass.
@@ -905,6 +915,7 @@
goal_is_atomic(conj([])).
goal_is_atomic(disj([], _)).
goal_is_atomic(higher_order_call(_,_,_,_,_,_)).
+goal_is_atomic(class_method_call(_,_,_,_,_,_)).
goal_is_atomic(call(_,_,_,_,_,_)).
goal_is_atomic(unify(_,_,_,_,_)).
goal_is_atomic(pragma_c_code(_,_,_,_,_,_,_,_)).
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_module.m,v
retrieving revision 1.25
diff -u -r1.25 hlds_module.m
--- hlds_module.m 1997/09/01 04:17:55 1.25
+++ hlds_module.m 1997/09/08 04:12:21
@@ -7,7 +7,7 @@
% This module defines the part of the High Level Data Structure or HLDS
% that deals with issues that are wider than a single predicate.
-% The four main data structures defined here are the types
+% The three main data structures defined here are the types
%
% module_info
% dependency_info
@@ -179,6 +179,12 @@
:- pred module_info_ctors(module_info, cons_table).
:- mode module_info_ctors(in, out) is det.
+:- pred module_info_classes(module_info, class_table).
+:- mode module_info_classes(in, out) is det.
+
+:- pred module_info_instances(module_info, instance_table).
+:- mode module_info_instances(in, out) is det.
+
:- pred module_info_num_errors(module_info, int).
:- mode module_info_num_errors(in, out) is det.
@@ -243,6 +249,12 @@
:- pred module_info_set_ctors(module_info, cons_table, module_info).
:- mode module_info_set_ctors(in, in, out) is det.
+:- pred module_info_set_classes(module_info, class_table, module_info).
+:- mode module_info_set_classes(in, in, out) is det.
+
+:- pred module_info_set_instances(module_info, instance_table, module_info).
+:- mode module_info_set_instances(in, in, out) is det.
+
:- pred module_info_set_dependency_info(module_info, dependency_info,
module_info).
:- mode module_info_set_dependency_info(in, in, out) is det.
@@ -344,6 +356,8 @@
inst_table,
mode_table,
cons_table,
+ class_table,
+ instance_table,
maybe(dependency_info),
int, % number of errors
%%% num_warnings not used:
@@ -388,47 +402,49 @@
BaseTypeData = base_gen_data([], []),
set__init(StratPreds),
map__init(UnusedArgInfo),
+ map__init(ClassTable),
+ map__init(InstanceTable),
Module_Info = module(Name, C_Code_Info, PredicateTable, Requests,
- UnifyPredMap, ContinuationInfo, Types, Insts, Modes,
- Ctors, DepInfo, 0, 0, PragmaExports, BaseTypeData, Globals,
- StratPreds, UnusedArgInfo, 0).
+ UnifyPredMap, ContinuationInfo, Types, Insts, Modes, Ctors,
+ ClassTable, InstanceTable, DepInfo, 0, 0, PragmaExports,
+ BaseTypeData, Globals, StratPreds, UnusedArgInfo, 0).
% Various access predicates which extract different pieces
% of info from the module_info data structure.
module_info_name(ModuleInfo, Name) :-
- ModuleInfo = module(Name, _, _, _, _, _, _, _, _, _, _, _, _,
- _, _, _, _, _, _).
+ ModuleInfo = module(Name, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ _, _, _, _, _, _, _).
module_info_get_c_header(ModuleInfo, C_Header) :-
- ModuleInfo = module(_, C_Code_Info, _, _, _, _, _, _, _, _, _, _,
- _, _, _, _, _, _, _),
+ ModuleInfo = module(_, C_Code_Info, _, _, _, _, _, _, _, _, _, _, _,
+ _, _, _, _, _, _, _, _),
C_Code_Info = c_code_info(C_Header, _).
module_info_set_c_header(ModuleInfo1, C_Header, ModuleInfo2) :-
ModuleInfo1 = module(A, C_Code_Info0,
- C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S),
+ C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U),
C_Code_Info0 = c_code_info(_C_Header0, C_Body),
C_Code_Info = c_code_info(C_Header, C_Body),
ModuleInfo2 = module(A, C_Code_Info,
- C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S).
+ C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U).
module_info_get_c_body_code(ModuleInfo, C_Body) :-
- ModuleInfo = module(_, C_Code_Info, _, _, _, _, _, _, _, _, _, _,
- _, _, _, _, _, _, _),
+ ModuleInfo = module(_, C_Code_Info, _, _, _, _, _, _, _, _, _, _, _,
+ _, _, _, _, _, _, _, _),
C_Code_Info = c_code_info(_, C_Body).
module_info_set_c_body_code(ModuleInfo1, C_Body, ModuleInfo2) :-
ModuleInfo1 = module(A, C_Code_Info0,
- C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S),
+ C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U),
C_Code_Info0 = c_code_info(C_Header, _C_Body0),
C_Code_Info = c_code_info(C_Header, C_Body),
ModuleInfo2 = module(A, C_Code_Info,
- C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S).
+ C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U).
module_info_get_predicate_table(ModuleInfo, PredicateTable) :-
ModuleInfo = module(_, _, PredicateTable,
- _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
+ _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
module_info_preds(ModuleInfo, Preds) :-
module_info_get_predicate_table(ModuleInfo, PredicateTable),
@@ -461,25 +477,25 @@
ModuleInfo).
module_info_get_unify_requests(ModuleInfo, Requests) :-
- ModuleInfo = module(_, _, _, Requests, _, _, _, _, _, _, _, _,
- _, _, _, _, _, _, _).
+ ModuleInfo = module(_, _, _, Requests, _, _, _, _, _, _, _, _, _,
+ _, _, _, _, _, _, _, _).
module_info_get_special_pred_map(ModuleInfo, SpecialPredMap) :-
ModuleInfo = module(_, _, _, _, SpecialPredMap,
- _, _, _, _, _, _, _, _, _, _, _, _, _, _).
+ _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
module_info_types(ModuleInfo, Types) :-
- ModuleInfo = module(_, _, _, _, _, _, Types, _, _, _, _, _, _,
- _, _, _, _, _, _).
+ ModuleInfo = module(_, _, _, _, _, _, Types, _, _, _, _, _, _, _,
+ _, _, _, _, _, _, _).
module_info_typeids(ModuleInfo, TypeIDs) :-
- ModuleInfo = module(_, _, _, _, _, _, Types, _, _, _, _, _, _,
- _, _, _, _, _, _),
+ ModuleInfo = module(_, _, _, _, _, _, Types, _, _, _, _, _, _, _,
+ _, _, _, _, _, _, _),
map__keys(Types, TypeIDs).
module_info_insts(ModuleInfo, Insts) :-
- ModuleInfo = module(_, _, _, _, _, _, _, Insts, _, _, _, _, _,
- _, _, _, _, _, _).
+ ModuleInfo = module(_, _, _, _, _, _, _, Insts, _, _, _, _, _, _,
+ _, _, _, _, _, _, _).
module_info_instids(ModuleInfo, InstIDs) :-
module_info_insts(ModuleInfo, InstTable),
@@ -487,25 +503,33 @@
user_inst_table_get_inst_ids(UserInstTable, InstIDs).
module_info_modes(ModuleInfo, Modes) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, Modes, _, _, _, _,
- _, _, _, _, _, _).
+ ModuleInfo = module(_, _, _, _, _, _, _, _, Modes, _, _, _, _, _,
+ _, _, _, _, _, _, _).
module_info_modeids(ModuleInfo, ModeIDs) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, Modes, _, _, _, _,
- _, _, _, _, _, _),
+ ModuleInfo = module(_, _, _, _, _, _, _, _, Modes, _, _, _, _, _,
+ _, _, _, _, _, _, _),
mode_table_get_mode_ids(Modes, ModeIDs).
module_info_ctors(ModuleInfo, Ctors) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, Ctors, _, _, _,
- _, _, _, _, _, _).
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, Ctors, _, _, _, _,
+ _, _, _, _, _, _, _).
+
+module_info_classes(ModuleInfo, Classes) :-
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, Classes, _, _, _,
+ _, _, _, _, _, _, _).
+
+module_info_instances(ModuleInfo, Instances) :-
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, Instances, _, _,
+ _, _, _, _, _, _, _).
module_info_consids(ModuleInfo, ConsIDs) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, Ctors, _, _, _,
- _, _, _, _, _, _),
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, Ctors, _, _, _, _,
+ _, _, _, _, _, _, _),
map__keys(Ctors, ConsIDs).
module_info_dependency_info(ModuleInfo, DepInfo) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, DepInfo0, _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, DepInfo0, _, _,
_, _, _, _, _, _),
( DepInfo0 = yes(DepInfo1) ->
DepInfo = DepInfo1
@@ -514,35 +538,35 @@
).
module_info_unused_arg_info(ModuleInfo, UnusedArgInfo) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
_, _, _, _, UnusedArgInfo, _).
module_info_dependency_info_built(ModuleInfo) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, yes(_), _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, yes(_), _, _,
_, _, _, _, _, _).
module_info_num_errors(ModuleInfo, NumErrors) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, NumErrors,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, NumErrors,
_, _, _, _, _, _, _).
module_info_base_gen_infos(ModuleInfo, BaseGenInfos) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
base_gen_data(BaseGenInfos, _), _, _, _, _).
module_info_base_gen_layouts(ModuleInfo, BaseGenLayouts) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
base_gen_data(_, BaseGenLayouts), _, _, _, _).
module_info_globals(ModuleInfo, Globals) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
Globals, _, _, _).
module_info_stratified_preds(ModuleInfo, StratPreds) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
_, StratPreds, _, _).
module_info_get_cell_count(ModuleInfo, CellCount) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
_, _, _, CellCount).
% not used:
@@ -553,15 +577,15 @@
module_info_set_name(ModuleInfo0, Name, ModuleInfo) :-
ModuleInfo0 = module(_, B, C, D, E, F, G, H, I, J, K, L, M, N,
- O, P, Q, R, S),
+ O, P, Q, R, S, T, U),
ModuleInfo = module(Name, B, C, D, E, F, G, H, I, J, K, L, M, N,
- O, P, Q, R, S).
+ O, P, Q, R, S, T, U).
module_info_set_predicate_table(ModuleInfo0, PredicateTable, ModuleInfo) :-
ModuleInfo0 = module(A, B, _, D, E, F, G, H, I, J, K, L, M, N,
- O, P, Q, R, S),
+ O, P, Q, R, S, T, U),
ModuleInfo = module(A, B, PredicateTable,
- D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S).
+ D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U).
module_info_set_preds(ModuleInfo0, Preds, ModuleInfo) :-
module_info_get_predicate_table(ModuleInfo0, PredicateTable0),
@@ -576,70 +600,82 @@
module_info_set_unify_requests(ModuleInfo0, Requests, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, _, E, F, G, H, I, J, K, L, M, N,
- O, P, Q, R, S),
+ O, P, Q, R, S, T, U),
ModuleInfo = module(A, B, C, Requests, E, F, G, H, I, J, K, L,
- M, N, O, P, Q, R, S).
+ M, N, O, P, Q, R, S, T, U).
module_info_set_special_pred_map(ModuleInfo0, SpecialPredMap, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, _, F, G, H, I, J, K, L, M,
- N, O, P, Q, R, S),
+ N, O, P, Q, R, S, T, U),
ModuleInfo = module(A, B, C, D, SpecialPredMap,
- F, G, H, I, J, K, L, M, N, O, P, Q, R, S).
+ F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U).
module_info_set_continuation_info(ModuleInfo0, ContinuationInfo, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, _, G, H, I, J, K, L, M, N,
- O, P, Q, R, S),
+ O, P, Q, R, S, T, U),
ModuleInfo = module(A, B, C, D, E, ContinuationInfo, G, H, I, J, K, L,
- M, N, O, P, Q, R, S).
+ M, N, O, P, Q, R, S, T, U).
module_info_set_types(ModuleInfo0, Types, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, F, _, H, I, J, K, L, M, N,
- O, P, Q, R, S),
+ O, P, Q, R, S, T, U),
ModuleInfo = module(A, B, C, D, E, F, Types, H, I, J, K, L, M,
- N, O, P, Q, R, S).
+ N, O, P, Q, R, S, T, U).
module_info_set_insts(ModuleInfo0, Insts, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, F, G, _, I, J, K, L, M, N,
- O, P, Q, R, S),
+ O, P, Q, R, S, T, U),
ModuleInfo = module(A, B, C, D, E, F, G, Insts, I, J, K, L, M,
- N, O, P, Q, R, S).
+ N, O, P, Q, R, S, T, U).
module_info_set_modes(ModuleInfo0, Modes, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, F, G, H, _, J, K, L, M, N,
- O, P, Q, R, S),
+ O, P, Q, R, S, T, U),
ModuleInfo = module(A, B, C, D, E, F, G, H, Modes, J, K, L, M,
- N, O, P, Q, R, S).
+ N, O, P, Q, R, S, T, U).
module_info_set_ctors(ModuleInfo0, Ctors, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, _, K, L, M, N,
- O, P, Q, R, S),
+ O, P, Q, R, S, T, U),
ModuleInfo = module(A, B, C, D, E, F, G, H, I, Ctors, K, L, M,
- N, O, P, Q, R, S).
+ N, O, P, Q, R, S, T, U).
-module_info_set_dependency_info(ModuleInfo0, DepInfo, ModuleInfo) :-
+module_info_set_classes(ModuleInfo0, Classes, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, _, L, M, N,
- O, P, Q, R, S),
- ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, yes(DepInfo),
- L, M, N, O, P, Q, R, S).
+ O, P, Q, R, S, T, U),
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, Classes, L, M,
+ N, O, P, Q, R, S, T, U).
+
+module_info_set_instances(ModuleInfo0, Instances, ModuleInfo) :-
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, _, M, N,
+ O, P, Q, R, S, T, U),
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, Instances, M,
+ N, O, P, Q, R, S, T, U).
+
+module_info_set_dependency_info(ModuleInfo0, DepInfo, ModuleInfo) :-
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, _, N,
+ O, P, Q, R, S, T, U),
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, yes(DepInfo),
+ N, O, P, Q, R, S, T, U).
module_info_clobber_dependency_info(ModuleInfo0, ModuleInfo) :-
- ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, _,
- L, M, N, O, P, Q, R, S),
- ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, no,
- L, M, N, O, P, Q, R, S).
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K,
+ L, _, N, O, P, Q, R, S, T, U),
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, no,
+ N, O, P, Q, R, S, T, U).
module_info_set_num_errors(ModuleInfo0, Errs, ModuleInfo) :-
- ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, _, M, N,
- O, P, Q, R, S),
- ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, Errs, M, N,
- O, P, Q, R, S).
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, _,
+ O, P, Q, R, S, T, U),
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, Errs,
+ O, P, Q, R, S, T, U).
module_info_incr_errors(ModuleInfo0, ModuleInfo) :-
- ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, Errs0, M,
- N, O, P, Q, R, S),
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, Errs0,
+ O, P, Q, R, S, T, U),
Errs is Errs0 + 1,
- ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, Errs, M, N,
- O, P, Q, R, S).
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, Errs,
+ O, P, Q, R, S, T, U).
/* not used
module_info_incr_warnings(ModuleInfo0, ModuleInfo) :-
@@ -648,55 +684,55 @@
ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, Warns).
*/
module_info_next_lambda_count(ModuleInfo0, Count, ModuleInfo) :-
- ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, Count0, N, O,
- P, Q, R, S),
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, Count0, O,
+ P, Q, R, S, T, U),
Count is Count0 + 1,
- ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, Count,
- N, O, P, Q, R, S).
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, Count, O,
+ P, Q, R, S, T, U).
module_info_get_continuation_info(ModuleInfo, ContinuationInfo) :-
ModuleInfo = module(_, _, _, _, _, ContinuationInfo, _, _, _, _, _, _,
- _, _, _, _, _, _, _).
+ _, _, _, _, _, _, _, _, _).
module_info_get_pragma_exported_procs(ModuleInfo, Procs) :-
- ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _,
+ ModuleInfo = module(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
Procs, _, _, _, _, _).
module_info_set_pragma_exported_procs(ModuleInfo0, Procs, ModuleInfo) :-
- ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, _,
- O, P, Q, R, S),
- ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, Procs,
- O, P, Q, R, S).
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
+ O, _, Q, R, S, T, U),
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, Procs,
+ Q, R, S, T, U).
module_info_set_base_gen_infos(ModuleInfo0, BaseGenInfos, ModuleInfo) :-
- ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- base_gen_data(_, BaseGenLayouts), P, Q, R, S),
- ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- base_gen_data(BaseGenInfos, BaseGenLayouts), P, Q, R, S).
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P,
+ base_gen_data(_, BaseGenLayouts), R, S, T, U),
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P,
+ base_gen_data(BaseGenInfos, BaseGenLayouts), R, S, T, U).
module_info_set_base_gen_layouts(ModuleInfo0, BaseGenLayouts, ModuleInfo) :-
- ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- base_gen_data(BaseGenInfos, _), P, Q, R, S),
- ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- base_gen_data(BaseGenInfos, BaseGenLayouts), P, Q, R, S).
+ ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P,
+ base_gen_data(BaseGenInfos, _), R, S, T, U),
+ ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P,
+ base_gen_data(BaseGenInfos, BaseGenLayouts), R, S, T, U).
module_info_set_stratified_preds(ModuleInfo0, StratPreds, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O,
- P, _, R, S),
+ P, Q, R, _, T, U),
ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- O, P, StratPreds, R, S).
+ O, P, Q, R, StratPreds, T, U).
module_info_set_unused_arg_info(ModuleInfo0, UnusedArgInfo, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K,
- L, M, N, O, P, Q, _, S),
+ L, M, N, O, P, Q, R, S, _, U),
ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K,
- L, M, N, O, P, Q, UnusedArgInfo, S).
+ L, M, N, O, P, Q, R, S, UnusedArgInfo, U).
module_info_set_cell_count(ModuleInfo0, CellCount, ModuleInfo) :-
ModuleInfo0 = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O,
- P, Q, R, _),
+ P, Q, R, S, T, _),
ModuleInfo = module(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- O, P, Q, R, CellCount).
+ O, P, Q, R, S, T, CellCount).
module_info_remove_predid(ModuleInfo0, PredId, ModuleInfo) :-
module_info_get_predicate_table(ModuleInfo0, PredicateTable0),
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.174
diff -u -r1.174 hlds_out.m
--- hlds_out.m 1997/10/13 08:09:43 1.174
+++ hlds_out.m 1997/10/14 07:14:20
@@ -205,6 +205,8 @@
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(_, _, _),
+ "<base_typeclass_info>").
hlds_out__write_cons_id(cons(SymName, Arity)) -->
(
@@ -231,6 +233,8 @@
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(_, _, _)) -->
+ io__write_string("<base_typeclass_info>").
hlds_out__write_pred_id(ModuleInfo, PredId) -->
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
@@ -447,8 +451,9 @@
{ pred_info_import_status(PredInfo, ImportStatus) },
{ pred_info_get_marker_list(PredInfo, Markers) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
+ { pred_info_get_class_context(PredInfo, ClassContext) },
mercury_output_pred_type(TVarSet, qualified(Module, PredName), ArgTypes,
- no, Context),
+ no, ClassContext, Context),
{ ClausesInfo = clauses_info(VarSet, _, VarTypes, HeadVars, Clauses) },
hlds_out__write_indent(Indent),
io__write_string("% pred id: "),
@@ -485,7 +490,12 @@
hlds_out__write_procs(Indent, AppendVarnums, ModuleInfo, PredId,
ImportStatus, ProcTable),
- io__write_string("\n").
+ io__write_string("\n"),
+
+ io__write_string("\n% Class Table:\n"),
+ { module_info_classes(ModuleInfo, ClassTable) },
+ % XXX fix this up.
+ io__write(ClassTable).
:- pred hlds_out__write_marker_list(list(marker_status), io__state, io__state).
:- mode hlds_out__write_marker_list(in, di, uo) is det.
@@ -515,6 +525,7 @@
hlds_out__marker_name(magic, "magic").
hlds_out__marker_name(obsolete, "obsolete").
hlds_out__marker_name(memo, "memo").
+hlds_out__marker_name(class_method, "class_method").
hlds_out__marker_name(terminates, "terminates").
hlds_out__marker_name(check_termination, "check_termination").
hlds_out__marker_name(does_not_terminate, "does_not_terminate").
@@ -987,6 +998,22 @@
io__write_string(Follow),
io__write_string("\n").
+hlds_out__write_goal_2(class_method_call(TCInfoVar, _, ArgVars, _, _, _),
+ _ModuleInfo, VarSet, AppendVarnums, Indent, Follow, _) -->
+ % XXX we should print more info here too
+ globals__io_lookup_string_option(verbose_dump_hlds, Verbose),
+ hlds_out__write_indent(Indent),
+ ( { string__contains_char(Verbose, 'l') } ->
+ io__write_string("% class method call"),
+ hlds_out__write_indent(Indent)
+ ;
+ []
+ ),
+ hlds_out__write_functor(term__atom("class_method_call"),
+ [TCInfoVar|ArgVars], VarSet, AppendVarnums),
+ io__write_string(Follow),
+ io__write_string("\n").
+
hlds_out__write_goal_2(call(PredId, ProcId, ArgVars, Builtin,
MaybeUnifyContext, PredName),
ModuleInfo, VarSet, AppendVarnums, Indent, Follow, TypeQual) -->
@@ -1358,6 +1385,19 @@
io__write_string(""", "),
io__write_int(Arity),
io__write_string(")")
+ ;
+ { ConsId = base_typeclass_info_const(Module,
+ class_id(Name, Arity), Instance) },
+ io__write_string("base_typeclass_info("""),
+ io__write_string(Module),
+ io__write_string(""", """),
+ io__write_string("class_id("),
+ prog_out__write_sym_name(Name),
+ io__write_string(", "),
+ io__write_int(Arity),
+ io__write_string("), "),
+ io__write_string(Instance),
+ io__write_string(")")
).
hlds_out__write_var_modes([], [], _, _) --> [].
@@ -1571,8 +1611,8 @@
hlds_out__write_var_types_2(Vars, Indent, VarSet, AppendVarnums,
VarTypes, TypeVarSet).
-:- pred hlds_out__write_typeinfo_varmap(int, bool, map(tvar, var), varset,
- tvarset, io__state, io__state).
+:- pred hlds_out__write_typeinfo_varmap(int, bool, map(tvar, type_info_locn),
+ varset, tvarset, io__state, io__state).
:- mode hlds_out__write_typeinfo_varmap(in, in, in, in, in, di, uo) is det.
hlds_out__write_typeinfo_varmap(Indent, AppendVarnums, TypeInfoMap, VarSet,
@@ -1584,7 +1624,7 @@
TypeInfoMap, VarSet, TVarSet).
:- pred hlds_out__write_typeinfo_varmap_2(list(tvar), int, bool,
- map(tvar, var), varset, tvarset, io__state, io__state).
+ map(tvar, type_info_locn), varset, tvarset, io__state, io__state).
:- mode hlds_out__write_typeinfo_varmap_2(in, in, in, in, in, in, di, uo)
is det.
@@ -1601,8 +1641,20 @@
io__write_string(")"),
io__write_string(" -> "),
- { map__lookup(TypeInfoMap, TVar, Var) },
- mercury_output_var(Var, VarSet, AppendVarnums),
+ { map__lookup(TypeInfoMap, TVar, Locn) },
+ (
+ { Locn = type_info(Var) },
+ io__write_string("type_info("),
+ mercury_output_var(Var, VarSet, AppendVarnums),
+ io__write_string(") ")
+ ;
+ { Locn = typeclass_info(Var, Index) },
+ io__write_string("typeclass_info("),
+ mercury_output_var(Var, VarSet, AppendVarnums),
+ io__write_string(", "),
+ io__write_int(Index),
+ io__write_string(") ")
+ ),
io__write_string(" (number "),
{ term__var_to_int(Var, VarNum) },
io__write_int(VarNum),
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.37
diff -u -r1.37 hlds_pred.m
--- hlds_pred.m 1997/10/31 00:14:25 1.37
+++ hlds_pred.m 1997/11/20 07:15:31
@@ -195,7 +195,7 @@
; obsolete % Requests warnings if this predicate is used.
% Used for pragma(obsolete).
% The `done' status is not meaningful.
- ; inline % Requests that this be predicate be inlined.
+ ; inline % Requests that this predicate be inlined.
% Used for pragma(inline).
% Since the transformation affects *other*
% predicates, the `done' status is not
@@ -213,6 +213,8 @@
; memo % Requests that this predicate be evaluated
% using memoing.
% Used for pragma(memo).
+ ; class_method % Requests that this predicate be transformed
+ % into the appropriate call to a class method
% The terminates and does_not_terminate
% pragmas are kept as markers to ensure
@@ -240,45 +242,56 @@
% but it is currently not used.
.
-
:- type marker_status
---> request(marker)
; done(marker).
+:- type type_info_locn
+ ---> type_info(var) % it is a normal type info
+ % (ie. the type is not constrained)
+ ; typeclass_info(var, int).
+ % it is packed inside a typeclass_info,
+ % and is at the given offset
+
+:- pred type_info_locn_var(type_info_locn::in, var::out) is det.
% hlds_pred__define_new_pred(Goal, CallGoal, Args, InstMap, PredName,
- % TVarSet, VarTypes, VarSet, Markers, ModuleInfo0, ModuleInfo,
- % PredProcId)
+ % TVarSet, VarTypes, ClassContext, VarSet, Markers, ModuleInfo0,
+ % ModuleInfo, PredProcId)
%
% Create a new predicate for the given goal, returning a goal to
% call the created predicate. This must only be called after
% polymorphism.m.
:- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(var),
- instmap, string, tvarset, map(var, type), varset,
+ instmap, string, tvarset, map(var, type),
+ list(class_constraint), varset,
list(marker_status), module_info, module_info, pred_proc_id).
:- mode hlds_pred__define_new_pred(in, out, in, in, in,
- in, in, in, in, in, out, out) is det.
+ in, in, in, in, in, in, out, out) is det.
% Various predicates for accessing the information stored in the
% pred_id and pred_info data structures.
:- pred pred_info_init(module_name, sym_name, arity, tvarset, list(type),
condition, term__context, clauses_info, import_status,
- list(marker_status), goal_type, pred_or_func, pred_info).
-:- mode pred_info_init(in, in, in, in, in, in, in, in, in, in, in, in, out)
- is det.
+ list(marker_status), goal_type, pred_or_func, list(class_constraint),
+ map(class_constraint, constraint_proof), pred_info).
+:- mode pred_info_init(in, in, in, in, in, in, in, in, in, in, in, in, in, in,
+ out) is det.
:- pred pred_info_create(module_name, sym_name, tvarset, list(type),
condition, term__context, import_status, list(marker_status),
- pred_or_func, proc_info, proc_id, pred_info).
-:- mode pred_info_create(in, in, in, in, in, in, in, in, in, in, out, out)
+ pred_or_func, list(class_constraint), proc_info, proc_id, pred_info).
+:- mode pred_info_create(in, in, in, in, in, in, in, in, in, in, in, out, out)
is det.
:- pred pred_info_set(tvarset, list(type), condition, clauses_info, proc_table,
term__context, module_name, string, arity, import_status,
- tvarset, goal_type, list(marker_status), pred_or_func, pred_info).
-:- mode pred_info_set(in, in, in, in, in, in, in, in, in, in, in, in, in, in,
- out) is det.
+ tvarset, goal_type, list(marker_status), pred_or_func,
+ list(class_constraint), map(class_constraint, constraint_proof),
+ pred_info).
+:- mode pred_info_set(in, in, in, in, in, in, in, in, in, in, in, in, in, in,
+ in, in, out) is det.
:- pred pred_info_module(pred_info, module_name).
:- mode pred_info_module(in, out) is det.
@@ -380,6 +393,21 @@
:- pred pred_info_get_is_pred_or_func(pred_info, pred_or_func).
:- mode pred_info_get_is_pred_or_func(in, out) is det.
+:- pred pred_info_get_class_context(pred_info, list(class_constraint)).
+:- mode pred_info_get_class_context(in, out) is det.
+
+:- pred pred_info_set_class_context(pred_info, list(class_constraint),
+ pred_info).
+:- mode pred_info_set_class_context(in, in, out) is det.
+
+:- pred pred_info_get_constraint_proofs(pred_info,
+ map(class_constraint, constraint_proof)).
+:- mode pred_info_get_constraint_proofs(in, out) is det.
+
+:- pred pred_info_set_constraint_proofs(pred_info,
+ map(class_constraint, constraint_proof), pred_info).
+:- mode pred_info_set_constraint_proofs(in, in, out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -444,21 +472,31 @@
list(marker_status),
% records which transformations
% have been done or are to be done
- pred_or_func % whether this "predicate" was really
+ pred_or_func, % whether this "predicate" was really
% a predicate or a function
+ list(class_constraint),
+ % the class constraints on the
+ % predicate
+ map(class_constraint, constraint_proof)
+ % explanations of how redundant
+ % constraints were eliminated. These
+ % are needed by polymorphism.m to
+ % work out where to get the
+ % typeclass_infos from.
).
pred_info_init(ModuleName, SymName, Arity, TypeVarSet, Types, Cond, Context,
- ClausesInfo, Status, Markers, GoalType, PredOrFunc, PredInfo) :-
+ ClausesInfo, Status, Markers, GoalType, PredOrFunc,
+ ClassContext, ClassProofs, PredInfo) :-
map__init(Procs),
unqualify_name(SymName, PredName),
sym_name_get_module_name(SymName, ModuleName, PredModuleName),
PredInfo = predicate(TypeVarSet, Types, Cond, ClausesInfo, Procs,
Context, PredModuleName, PredName, Arity, Status, TypeVarSet,
- GoalType, Markers, PredOrFunc).
+ GoalType, Markers, PredOrFunc, ClassContext, ClassProofs).
pred_info_create(ModuleName, SymName, TypeVarSet, Types, Cond, Context,
- Status, Markers, PredOrFunc, ProcInfo, ProcId,
+ Status, Markers, PredOrFunc, ClassContext, ProcInfo, ProcId,
PredInfo) :-
map__init(Procs0),
proc_info_declared_determinism(ProcInfo, MaybeDetism),
@@ -471,19 +509,22 @@
unqualify_name(SymName, PredName),
% The empty list of clauses is a little white lie.
ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, HeadVars, []),
+ map__init(ClassProofs),
PredInfo = predicate(TypeVarSet, Types, Cond, ClausesInfo, Procs,
Context, ModuleName, PredName, Arity, Status, TypeVarSet,
- clauses, Markers, PredOrFunc).
+ clauses, Markers, PredOrFunc, ClassContext, ClassProofs).
pred_info_set(HeadTVarSet, Types, Cond, ClausesInfo, Procs, Context,
PredModuleName, PredName, Arity, Status, AllTVarSet,
- GoalType, Markers, PredOrFunc, PredInfo) :-
+ GoalType, Markers, PredOrFunc, ClassContext, ClassProofs,
+ PredInfo) :-
PredInfo = predicate(HeadTVarSet, Types, Cond, ClausesInfo, Procs,
Context, PredModuleName, PredName, Arity, Status, AllTVarSet,
- GoalType, Markers, PredOrFunc).
+ GoalType, Markers, PredOrFunc, ClassContext, ClassProofs).
pred_info_procids(PredInfo, ProcIds) :-
- PredInfo = predicate(_, _, _, _, Procs, _, _, _, _, _, _, _, _, _),
+ PredInfo = predicate(_, _, _, _, Procs, _, _, _, _, _, _, _,
+ _, _, _, _),
map__keys(Procs, ProcIds).
pred_info_non_imported_procids(PredInfo, ProcIds) :-
@@ -509,43 +550,51 @@
).
pred_info_clauses_info(PredInfo, Clauses) :-
- PredInfo = predicate(_, _, _, Clauses, _, _, _, _, _, _, _, _, _, _).
+ PredInfo = predicate(_, _, _, Clauses, _, _, _, _, _, _, _, _,
+ _, _, _, _).
pred_info_set_clauses_info(PredInfo0, Clauses, PredInfo) :-
- PredInfo0 = predicate(A, B, C, _, E, F, G, H, I, J, K, L, M, N),
- PredInfo = predicate(A, B, C, Clauses, E, F, G, H, I, J, K, L, M, N).
+ PredInfo0 = predicate(A, B, C, _, E, F, G, H, I, J, K, L, M, N, O, P),
+ PredInfo = predicate(A, B, C, Clauses, E, F, G, H, I, J, K,
+ L, M, N, O, P).
pred_info_arg_types(PredInfo, TypeVars, ArgTypes) :-
PredInfo = predicate(TypeVars, ArgTypes,
- _, _, _, _, _, _, _, _, _, _, _, _).
+ _, _, _, _, _, _, _, _, _, _, _, _, _, _).
pred_info_set_arg_types(PredInfo0, TypeVarSet, ArgTypes, PredInfo) :-
- PredInfo0 = predicate(_, _, C, D, E, F, G, H, I, J, K, L, M, N),
+ PredInfo0 = predicate(_, _, C, D, E, F, G, H, I, J, K, L, M, N, O, P),
PredInfo = predicate(TypeVarSet, ArgTypes,
- C, D, E, F, G, H, I, J, K, L, M, N).
+ C, D, E, F, G, H, I, J, K, L, M, N, O, P).
pred_info_procedures(PredInfo, Procs) :-
- PredInfo = predicate(_, _, _, _, Procs, _, _, _, _, _, _, _, _, _).
+ PredInfo = predicate(_, _, _, _, Procs, _, _, _, _, _, _,
+ _, _, _, _, _).
pred_info_set_procedures(PredInfo0, Procedures, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, _, F, G, H, I, J, K, L, M, N),
- PredInfo = predicate(A, B, C, D, Procedures, F, G, H, I, J, K, L, M, N).
+ PredInfo0 = predicate(A, B, C, D, _, F, G, H, I, J, K, L, M, N, O, P),
+ PredInfo = predicate(A, B, C, D, Procedures, F, G, H, I, J, K, L, M,
+ N, O, P).
pred_info_context(PredInfo, Context) :-
- PredInfo = predicate(_, _, _, _, _, Context, _, _, _, _, _, _, _, _).
+ PredInfo = predicate(_, _, _, _, _, Context, _, _, _,
+ _, _, _, _, _, _, _).
pred_info_module(PredInfo, Module) :-
- PredInfo = predicate(_, _, _, _, _, _, Module, _, _, _, _, _, _, _).
+ PredInfo = predicate(_, _, _, _, _, _, Module, _, _, _, _,
+ _, _, _, _, _).
pred_info_name(PredInfo, PredName) :-
- PredInfo = predicate(_, _, _, _, _, _, _, PredName, _, _, _, _, _, _).
+ PredInfo = predicate(_, _, _, _, _, _, _, PredName, _, _, _,
+ _, _, _, _, _).
pred_info_arity(PredInfo, Arity) :-
- PredInfo = predicate(_, _, _, _, _, _, _, _, Arity, _, _, _, _, _).
+ PredInfo = predicate(_, _, _, _, _, _, _, _, Arity, _, _,
+ _, _, _, _, _).
pred_info_import_status(PredInfo, ImportStatus) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, ImportStatus, _, _, _,
- _).
+ _, _, _).
pred_info_is_imported(PredInfo) :-
pred_info_import_status(PredInfo, imported).
@@ -563,27 +612,32 @@
ImportStatus = pseudo_exported.
pred_info_mark_as_external(PredInfo0, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, _, K, L, M, N),
- PredInfo = predicate(A, B, C, D, E, F, G, H, I, imported, K, L, M, N).
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O, P),
+ PredInfo = predicate(A, B, C, D, E, F, G, H, I, imported, K, L, M,
+ N, O, P).
pred_info_set_import_status(PredInfo0, Status, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, _, K, L, M, N),
- PredInfo = predicate(A, B, C, D, E, F, G, H, I, Status, K, L, M, N).
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O, P),
+ PredInfo = predicate(A, B, C, D, E, F, G, H, I, Status, K,
+ L, M, N, O, P).
pred_info_typevarset(PredInfo, TypeVarSet) :-
- PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, TypeVarSet, _, _, _).
+ PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, TypeVarSet, _, _,
+ _, _, _).
pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, _, L, M, N),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, _, L, M, N, O, P),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, TypeVarSet, L, M,
- N).
+ N, O, P).
pred_info_get_goal_type(PredInfo, GoalType) :-
- PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, GoalType, _, _).
+ PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, GoalType, _,
+ _, _, _).
pred_info_set_goal_type(PredInfo0, GoalType, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, _, M, N),
- PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, GoalType, M, N).
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, _, M, N, O, P),
+ PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, GoalType, M,
+ N, O, P).
pred_info_requested_inlining(PredInfo0) :-
pred_info_get_marker_list(PredInfo0, Markers),
@@ -594,20 +648,46 @@
list__member(request(no_inline), Markers).
pred_info_get_marker_list(PredInfo, Markers) :-
- PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, Markers, _).
+ PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _,
+ _, Markers, _, _, _).
pred_info_set_marker_list(PredInfo0, Markers, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, _, N),
- PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, Markers, N).
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O, P),
+ PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, Markers,
+ N, O, P).
pred_info_get_is_pred_or_func(PredInfo, IsPredOrFunc) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, _,
- IsPredOrFunc).
+ IsPredOrFunc, _, _).
+
+pred_info_set_class_context(PredInfo0, ClassContext, PredInfo) :-
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N, _, P),
+ PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
+ ClassContext, P).
+
+pred_info_get_class_context(PredInfo, ClassContext) :-
+ PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ ClassContext, _).
+
+pred_info_set_constraint_proofs(PredInfo0, Proofs, PredInfo) :-
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, _),
+ PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
+ O, Proofs).
+
+pred_info_get_constraint_proofs(PredInfo, ConstraintProofs) :-
+ PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ ConstraintProofs).
%-----------------------------------------------------------------------------%
+type_info_locn_var(type_info(Var), Var).
+type_info_locn_var(typeclass_info(Var, _), Var).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
hlds_pred__define_new_pred(Goal0, Goal, ArgVars, InstMap0, PredName, TVarSet,
- VarTypes, VarSet, Markers, ModuleInfo0,
+ VarTypes, ClassContext, VarSet, Markers, ModuleInfo0,
ModuleInfo, PredProcId) :-
Goal0 = _GoalExpr - GoalInfo,
goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
@@ -621,10 +701,12 @@
module_info_name(ModuleInfo0, ModuleName),
SymName = qualified(ModuleName, PredName),
map__init(TVarMap), % later, polymorphism.m will fill this in.
+ map__init(TCVarMap), % later, polymorphism.m will fill this in.
proc_info_create(VarSet, VarTypes, ArgVars, ArgModes, Detism,
- Goal0, Context, TVarMap, ProcInfo),
+ Goal0, Context, TVarMap, TCVarMap, ProcInfo),
pred_info_create(ModuleName, SymName, TVarSet, ArgTypes, true,
- Context, local, Markers, predicate, ProcInfo, ProcId, PredInfo),
+ Context, local, Markers, predicate, ClassContext,
+ ProcInfo, ProcId, PredInfo),
module_info_get_predicate_table(ModuleInfo0, PredTable0),
predicate_table_insert(PredTable0, PredInfo, PredId,
@@ -663,13 +745,15 @@
:- pred proc_info_set(maybe(determinism), varset, map(var, type), list(var),
list(mode), maybe(list(is_live)), hlds_goal, term__context,
stack_slots, determinism, bool, list(arg_info), liveness_info,
- map(tvar, var), termination, proc_info).
+ map(tvar, type_info_locn), map(class_constraint, var), termination,
+ proc_info).
:- mode proc_info_set(in, in, in, in, in, in, in, in, in, in, in, in, in, in,
- in, out) is det.
+ in, in, out) is det.
:- pred proc_info_create(varset, map(var, type), list(var), list(mode),
- determinism, hlds_goal, term__context, map(tvar, var), proc_info).
-:- mode proc_info_create(in, in, in, in, in, in, in, in, out) is det.
+ determinism, hlds_goal, term__context, map(tvar, type_info_locn),
+ map(class_constraint, var), proc_info).
+:- mode proc_info_create(in, in, in, in, in, in, in, in, in, out) is det.
:- pred proc_info_set_body(proc_info, varset, map(var, type), list(var),
hlds_goal, proc_info).
@@ -775,12 +859,20 @@
:- pred proc_info_set_can_process(proc_info, bool, proc_info).
:- mode proc_info_set_can_process(in, in, out) is det.
-:- pred proc_info_typeinfo_varmap(proc_info, map(tvar, var)).
+:- pred proc_info_typeinfo_varmap(proc_info, map(tvar, type_info_locn)).
:- mode proc_info_typeinfo_varmap(in, out) is det.
-:- pred proc_info_set_typeinfo_varmap(proc_info, map(tvar, var), proc_info).
+:- pred proc_info_set_typeinfo_varmap(proc_info, map(tvar, type_info_locn),
+ proc_info).
:- mode proc_info_set_typeinfo_varmap(in, in, out) is det.
+:- pred proc_info_typeclass_info_varmap(proc_info, map(class_constraint, var)).
+:- mode proc_info_typeclass_info_varmap(in, out) is det.
+
+:- pred proc_info_set_typeclass_info_varmap(proc_info,
+ map(class_constraint, var), proc_info).
+:- mode proc_info_set_typeclass_info_varmap(in, in, out) is det.
+
:- pred proc_info_maybe_declared_argmodes(proc_info, maybe(list(mode))).
:- mode proc_info_maybe_declared_argmodes(in, out) is det.
@@ -843,8 +935,12 @@
% should be passed.
liveness_info, % the initial liveness,
% for code generation
- map(tvar, var), % typeinfo vars for
+ map(tvar, type_info_locn),
+ % typeinfo vars for
% type parameters
+ map(class_constraint, var),
+ % typeclass_info vars for class
+ % constraints
termination, % The termination properties of the
% procedure. Initially 'not_set'.
% Final value inferred by termination.m
@@ -874,37 +970,40 @@
ClauseBody = conj([]) - GoalInfo,
CanProcess = yes,
map__init(TVarsMap),
+ map__init(TCVarsMap),
term_util__init(Termination),
NewProc = procedure(
MaybeDet, BodyVarSet, BodyTypes, HeadVars, Modes, MaybeArgLives,
ClauseBody, MContext, StackSlots, InferredDet, CanProcess,
- ArgInfo, InitialLiveness, TVarsMap, Termination, DeclaredModes
+ ArgInfo, InitialLiveness, TVarsMap, TCVarsMap, Termination,
+ DeclaredModes
).
proc_info_set(DeclaredDetism, BodyVarSet, BodyTypes, HeadVars, HeadModes,
HeadLives, Goal,
Context, StackSlots, InferredDetism, CanProcess,
- ArgInfo, Liveness, TVarMap, Termination, ProcInfo) :-
+ ArgInfo, Liveness, TVarMap, TCVarsMap, Termination, ProcInfo) :-
ProcInfo = procedure(
DeclaredDetism, BodyVarSet, BodyTypes, HeadVars, HeadModes,
HeadLives, Goal, Context, StackSlots, InferredDetism,
- CanProcess, ArgInfo, Liveness, TVarMap, Termination, no).
+ CanProcess, ArgInfo, Liveness, TVarMap, TCVarsMap, Termination,
+ no).
proc_info_create(VarSet, VarTypes, HeadVars, HeadModes, Detism, Goal,
- Context, TVarMap, ProcInfo) :-
+ Context, TVarMap, TCVarsMap, ProcInfo) :-
map__init(StackSlots),
set__init(Liveness),
term_util__init(Termination),
MaybeHeadLives = no,
ProcInfo = procedure(yes(Detism), VarSet, VarTypes, HeadVars, HeadModes,
MaybeHeadLives, Goal, Context, StackSlots, Detism, yes, [],
- Liveness, TVarMap, Termination, no).
+ Liveness, TVarMap, TCVarsMap, Termination, no).
proc_info_set_body(ProcInfo0, VarSet, VarTypes, HeadVars, Goal, ProcInfo) :-
ProcInfo0 = procedure(A, _, _, _, E, F, _,
- H, I, J, K, L, M, N, O, P),
+ H, I, J, K, L, M, N, O, P, Q),
ProcInfo = procedure(A, VarSet, VarTypes, HeadVars, E, F, Goal,
- H, I, J, K, L, M, N, O, P).
+ H, I, J, K, L, M, N, O, P, Q).
proc_info_interface_determinism(ProcInfo, Determinism) :-
proc_info_declared_determinism(ProcInfo, MaybeDeterminism),
@@ -953,45 +1052,55 @@
instmap__from_assoc_list(InstAL, InstMap).
proc_info_declared_determinism(ProcInfo, Detism) :-
- ProcInfo = procedure(Detism, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
+ ProcInfo = procedure(Detism, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ _, _).
proc_info_variables(ProcInfo, VarSet) :-
- ProcInfo = procedure(_, VarSet, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
+ ProcInfo = procedure(_, VarSet, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ _, _).
proc_info_vartypes(ProcInfo, VarTypes) :-
- ProcInfo = procedure(_, _, VarTypes, _, _, _, _, _,
- _, _, _, _, _, _, _, _).
+ ProcInfo = procedure(_, _, VarTypes, _, _, _, _, _, _,
+ _, _, _, _, _, _, _, _).
proc_info_headvars(ProcInfo, HeadVars) :-
- ProcInfo = procedure(_, _, _, HeadVars, _, _, _, _,
- _, _, _, _, _, _, _, _).
+ ProcInfo = procedure(_, _, _, HeadVars, _, _, _, _, _, _,
+ _, _, _, _, _, _, _).
proc_info_argmodes(ProcInfo, Modes) :-
- ProcInfo = procedure(_, _, _, _, Modes, _, _, _, _, _, _, _, _, _, _, _).
+ ProcInfo = procedure(_, _, _, _, Modes, _, _, _, _, _, _, _, _, _, _,
+ _, _).
proc_info_maybe_arglives(ProcInfo, ArgLives) :-
- ProcInfo = procedure(_, _, _, _, _, ArgLives,
- _, _, _, _, _, _, _, _, _, _).
+ ProcInfo = procedure(_, _, _, _, _, ArgLives, _, _, _,
+ _, _, _, _, _, _, _, _).
proc_info_goal(ProcInfo, Goal) :-
- ProcInfo = procedure(_, _, _, _, _, _, Goal, _, _, _, _, _, _, _, _, _).
+ ProcInfo = procedure(_, _, _, _, _, _, Goal, _, _, _, _, _, _, _, _,
+ _, _).
proc_info_context(ProcInfo, Context) :-
- ProcInfo = procedure(_, _, _, _, _, _, _, Context, _, _, _, _, _, _, _, _).
+ ProcInfo = procedure(_, _, _, _, _, _, _, Context,
+ _, _, _, _, _, _, _, _, _).
proc_info_stack_slots(ProcInfo, StackSlots) :-
- ProcInfo = procedure(_, _, _, _, _, _, _, _, StackSlots,
- _, _, _, _, _, _, _).
+ ProcInfo = procedure(_, _, _, _, _, _, _, _, StackSlots,
+ _, _, _, _, _, _, _, _).
proc_info_inferred_determinism(ProcInfo, Detism) :-
- ProcInfo = procedure(_, _, _, _, _, _, _, _, _, Detism, _, _, _, _, _, _).
+ ProcInfo = procedure(_, _, _, _, _, _, _, _, _, Detism, _, _, _, _, _,
+ _, _).
proc_info_can_process(ProcInfo, CanProcess) :-
- ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, CanProcess,
- _, _, _, _, _).
-proc_info_arg_info(ProcInfo, ArgInfo) :-
- ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, ArgInfo,
- _, _, _, _).
+ ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, CanProcess,
+ _, _, _, _, _, _).
+proc_info_arg_info(ProcInfo, ArgInfo) :-
+ ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, ArgInfo,
+ _, _, _, _, _).
proc_info_liveness_info(ProcInfo, Liveness) :-
- ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, Liveness,
- _, _, _).
+ ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, Liveness,
+ _, _, _, _).
proc_info_typeinfo_varmap(ProcInfo, TVarMap) :-
- ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, TVarMap, _, _).
+ ProcInfo = procedure(_, _, _, _, _, _, _,
+ _, _, _, _, _, _, TVarMap, _, _, _).
+proc_info_typeclass_info_varmap(ProcInfo, TCVarMap) :-
+ ProcInfo = procedure(_, _, _, _, _, _, _,
+ _, _, _, _, _, _, _, TCVarMap, _, _).
proc_info_termination(ProcInfo, Termination) :-
- ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
Termination, _).
proc_info_maybe_declared_argmodes(ProcInfo, MaybeArgModes) :-
- ProcInfo = procedure(_, _, _, _, _, _, _,
+ ProcInfo = procedure(_, _, _, _, _, _, _, _,
_, _, _, _, _, _, _, _, MaybeArgModes).
proc_info_declared_argmodes(ProcInfo, ArgModes) :-
@@ -1021,74 +1130,76 @@
% % derived from the
% % modes etc
% M liveness_info % the initial liveness
-% N map(tvar, var) % typeinfo vars to
+% N map(tvar, type_info_locn)
+% % typeinfo vars to
+% % locations.
+% O map(class_constraint, var)
+% % constraints to
% % vars.
-% O termination % Termination analys
-% P maybe(list(mode)) % declared modes
+% P termination % Termination analys
+% Q maybe(list(mode)) % declared modes
% % of args
% ).
proc_info_set_varset(ProcInfo0, VarSet, ProcInfo) :-
- ProcInfo0 = procedure(A, _, C, D, E, F, G, H, I, J, K, L, M, N, O, P),
- ProcInfo = procedure(A, VarSet, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
+ ProcInfo0 = procedure(A,_,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,VarSet,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q).
proc_info_set_variables(ProcInfo0, Vars, ProcInfo) :-
- ProcInfo0 = procedure(A, _, C, D, E, F, G, H, I, J, K, L, M, N, O, P),
- ProcInfo = procedure(A, Vars, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
+ ProcInfo0 = procedure(A,_,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,Vars,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q).
proc_info_set_vartypes(ProcInfo0, Vars, ProcInfo) :-
- ProcInfo0 = procedure(A, B, _, D, E, F, G, H, I, J, K, L, M, N, O, P),
- ProcInfo = procedure(A, B, Vars, D, E, F, G, H, I, J, K, L, M, N, O, P).
+ ProcInfo0 = procedure(A,B,_,D,E,F,G,H,I,J,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,Vars,D,E,F,G,H,I,J,K,L,M,N,O,P,Q).
-proc_info_set_headvars(ProcInfo0, HdVars, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, _, E, F, G, H, I, J, K, L, M, N, O, P),
- ProcInfo = procedure(A, B, C, HdVars, E, F, G, H, I, J, K, L, M, N, O, P).
+proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo) :-
+ ProcInfo0 = procedure(A,B,C,_,E,F,G,H,I,J,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,HeadVars,E,F,G,H,I,J,K,L,M,N,O,P,Q).
proc_info_set_argmodes(ProcInfo0, ArgModes, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, _, F, G, H, I, J, K, L, M, N, O, P),
- ProcInfo = procedure(A, B, C, D, ArgModes, F, G, H, I,
- J, K, L, M, N, O, P).
+ ProcInfo0 = procedure(A,B,C,D,_,F,G,H,I,J,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,ArgModes,F,G,H,I,J,K,L,M,N,O,P,Q).
proc_info_set_maybe_arglives(ProcInfo0, ArgLives, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, _, G, H, I, J, K, L, M, N, O, P),
- ProcInfo = procedure(A, B, C, D, E, ArgLives, G, H, I,
- J, K, L, M, N, O, P).
+ ProcInfo0 = procedure(A,B,C,D,E,_,G,H,I,J,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,ArgLives,G,H,I,J,K,L,M,N,O,P,Q).
proc_info_set_inferred_determinism(ProcInfo0, Detism, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O, P),
- ProcInfo = procedure(A, B, C, D, E, F, G, H, I, Detism, K, L, M, N, O, P).
+ ProcInfo0 = procedure(A,B,C,D,E,F,G,H,I,_,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,G,H,I,Detism,K,L,M,N,O,P,Q).
proc_info_set_can_process(ProcInfo0, CanProcess, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, _, L, M, N, O, P),
- ProcInfo = procedure(A, B, C, D, E, F, G, H, I, J, CanProcess,
- L, M, N, O, P).
+ ProcInfo0 = procedure(A,B,C,D,E,F,G,H,I,J,_,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,G,H,I,J,CanProcess,L,M,N,O,P,Q).
proc_info_set_goal(ProcInfo0, Goal, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, F, _, H, I, J, K, L, M, N, O, P),
- ProcInfo = procedure(A, B, C, D, E, F, Goal, H, I, J, K, L, M, N, O, P).
+ ProcInfo0 = procedure(A,B,C,D,E,F,_,H,I,J,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,Goal,H,I,J,K,L,M,N,O,P,Q).
proc_info_set_stack_slots(ProcInfo0, StackSlots, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, _, J, K, L, M, N, O, P),
- ProcInfo = procedure(A, B, C, D, E, F, G, H, StackSlots, J, K,
- L, M, N, O, P).
+ ProcInfo0 = procedure(A,B,C,D,E,F,G,H,_,J,K,L,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,G,H,StackSlots,J,K,L,M,N,O,P,Q).
proc_info_set_arg_info(ProcInfo0, ArgInfo, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, _, M, N, O, P),
- ProcInfo = procedure(A, B, C, D, E, F, G, H, I, J, K, ArgInfo, M, N, O, P).
+ ProcInfo0 = procedure(A,B,C,D,E,F,G,H,I,J,K,_,M,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,G,H,I,J,K,ArgInfo,M,N,O,P,Q).
proc_info_set_liveness_info(ProcInfo0, Liveness, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O, P),
- ProcInfo = procedure(A, B, C, D, E, F, G, H, I, J, K, L, Liveness,
- N, O, P).
+ ProcInfo0 = procedure(A,B,C,D,E,F,G,H,I,J,K,L,_,N,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,G,H,I,J,K,L,Liveness,N,O,P,Q).
proc_info_set_typeinfo_varmap(ProcInfo0, TVarMap, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, _, O, P),
- ProcInfo = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, TVarMap, O, P).
+ ProcInfo0 = procedure(A,B,C,D,E,F,G,H,I,J,K,L,M,_,O,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,G,H,I,J,K,L,M,TVarMap,O,P,Q).
+
+proc_info_set_typeclass_info_varmap(ProcInfo0, TCVarMap, ProcInfo) :-
+ ProcInfo0 = procedure(A,B,C,D,E,F,G,H,I,J,K,L,M,N,_,P,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,G,H,I,J,K,L,M,N,TCVarMap,P,Q).
proc_info_set_termination(ProcInfo0, Terminat, ProcInfo) :-
- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, _, P),
- ProcInfo = procedure(A, B, C, D, E, F, G, H, I, J, K, L,
- M, N, Terminat, P).
+ ProcInfo0 = procedure(A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,_,Q),
+ ProcInfo = procedure(A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,Terminat,Q).
proc_info_get_typeinfo_vars_setwise(ProcInfo, Vars, TypeInfoVars) :-
set__to_sorted_list(Vars, VarList),
@@ -1117,7 +1228,18 @@
% higher order pred types here -- if so, maybe
% treat them specially.
proc_info_typeinfo_varmap(ProcInfo, TVarMap),
- map__apply_to_list(TypeVars, TVarMap, TypeInfoVars0),
+
+ % The type_info is either stored in a variable,
+ % or in a typeclass_info. Either get the
+ % type_info variable or the typeclass_info
+ % variable
+ LookupVar = lambda([TVar::in, TVarVar::out] is det,
+ (
+ map__lookup(TVarMap, TVar, Locn),
+ type_info_locn_var(Locn, TVarVar)
+ )),
+ list__map(LookupVar, TypeVars, TypeInfoVars0),
+
proc_info_get_typeinfo_vars_2(ProcInfo, Vars1,
TypeInfoVars1),
list__append(TypeInfoVars0, TypeInfoVars1, TypeInfoVars)
Index: compiler/inlining.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/inlining.m,v
retrieving revision 1.69
diff -u -r1.69 inlining.m
--- inlining.m 1997/09/01 14:02:31 1.69
+++ inlining.m 1997/09/08 04:51:26
@@ -312,7 +312,7 @@
varset, % varset
map(var, type), % variable types
tvarset, % type variables
- map(tvar, var), % type_info varset, a mapping from
+ map(tvar, type_info_locn),% type_info varset, a mapping from
% type variables to variables
% where their type_info is
% stored.
@@ -520,6 +520,9 @@
inlining__inlining_in_goal(higher_order_call(A, B, C, D, E, F) - GoalInfo,
higher_order_call(A, B, C, D, E, F) - GoalInfo) --> [].
+
+inlining__inlining_in_goal(class_method_call(A, B, C, D, E, F) - GoalInfo,
+ class_method_call(A, B, C, D, E, F) - GoalInfo) --> [].
inlining__inlining_in_goal(unify(A, B, C, D, E) - GoalInfo,
unify(A, B, C, D, E) - GoalInfo) --> [].
Index: compiler/intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.34
diff -u -r1.34 intermod.m
--- intermod.m 1997/10/26 23:05:36 1.34
+++ intermod.m 1997/11/17 02:38:53
@@ -387,6 +387,9 @@
intermod__traverse_goal(higher_order_call(A,B,C,D,E,F) - Info,
higher_order_call(A,B,C,D,E,F) - Info, yes) --> [].
+intermod__traverse_goal(class_method_call(A,B,C,D,E,F) - Info,
+ class_method_call(A,B,C,D,E,F) - Info, yes) --> [].
+
intermod__traverse_goal(switch(A, B, Cases0, D) - Info,
switch(A, B, Cases, D) - Info, DoWrite) -->
intermod__traverse_cases(Cases0, Cases, DoWrite).
@@ -851,16 +854,17 @@
{ pred_info_arg_types(PredInfo, TVarSet, ArgTypes) },
{ pred_info_context(PredInfo, Context) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
+ { pred_info_get_class_context(PredInfo, ClassContext) },
(
{ PredOrFunc = predicate },
mercury_output_pred_type(TVarSet, qualified(Module, Name),
- ArgTypes, no, Context)
+ ArgTypes, no, ClassContext, Context)
;
{ PredOrFunc = function },
{ pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType) },
mercury_output_func_type(TVarSet,
qualified(Module, Name), FuncArgTypes,
- FuncRetType, no, Context)
+ FuncRetType, no, ClassContext, Context)
),
{ pred_info_procedures(PredInfo, Procs) },
{ pred_info_procids(PredInfo, ProcIds) },
Index: compiler/lambda.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/lambda.m,v
retrieving revision 1.32
diff -u -r1.32 lambda.m
--- lambda.m 1997/09/01 14:02:47 1.32
+++ lambda.m 1997/10/17 05:38:54
@@ -43,10 +43,11 @@
:- pred lambda__transform_lambda(pred_or_func, string, list(var), list(mode),
determinism, set(var), hlds_goal, unification,
- varset, map(var, type), tvarset, map(tvar, var), module_info,
- unify_rhs, unification, module_info).
+ varset, map(var, type), list(class_constraint), tvarset,
+ map(tvar, type_info_locn), map(class_constraint, var),
+ module_info, unify_rhs, unification, module_info).
:- mode lambda__transform_lambda(in, in, in, in, in, in, in, in, in, in, in, in,
- in, out, out, out) is det.
+ in, in, in, out, out, out) is det.
% Permute the list of variables so that inputs come before outputs.
:- pred lambda__permute_argvars(list(var), list(mode), module_info,
@@ -67,8 +68,14 @@
lambda_info(
varset, % from the proc_info
map(var, type), % from the proc_info
+ list(class_constraint), % from the pred_info
tvarset, % from the proc_info
- map(tvar, var), % from the proc_info (typeinfos)
+ map(tvar, type_info_locn),
+ % from the proc_info
+ % (typeinfos)
+ map(class_constraint, var),
+ % from the proc_info
+ % (typeclass_infos)
pred_or_func,
string, % pred/func name
module_info
@@ -120,26 +127,28 @@
pred_info_name(PredInfo0, PredName),
pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc),
pred_info_typevarset(PredInfo0, TypeVarSet0),
+ pred_info_get_class_context(PredInfo0, Constraints0),
proc_info_variables(ProcInfo0, VarSet0),
proc_info_vartypes(ProcInfo0, VarTypes0),
proc_info_goal(ProcInfo0, Goal0),
proc_info_typeinfo_varmap(ProcInfo0, TVarMap0),
+ proc_info_typeclass_info_varmap(ProcInfo0, TCVarMap0),
% process the goal
- Info0 = lambda_info(VarSet0, VarTypes0, TypeVarSet0, TVarMap0,
- PredOrFunc, PredName,
- ModuleInfo0),
+ Info0 = lambda_info(VarSet0, VarTypes0, Constraints0, TypeVarSet0,
+ TVarMap0, TCVarMap0, PredOrFunc, PredName, ModuleInfo0),
lambda__process_goal(Goal0, Goal, Info0, Info),
- Info = lambda_info(VarSet, VarTypes, TypeVarSet, TVarMap,
- _, _,
- ModuleInfo),
+ Info = lambda_info(VarSet, VarTypes, Constraints, TypeVarSet,
+ TVarMap, TCVarMap, _, _, ModuleInfo),
% set the new values of the fields in proc_info and pred_info
proc_info_set_goal(ProcInfo0, Goal, ProcInfo1),
proc_info_set_variables(ProcInfo1, VarSet, ProcInfo2),
proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo3),
- proc_info_set_typeinfo_varmap(ProcInfo3, TVarMap, ProcInfo),
- pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
+ proc_info_set_typeinfo_varmap(ProcInfo3, TVarMap, ProcInfo4),
+ proc_info_set_typeclass_info_varmap(ProcInfo4, TCVarMap, ProcInfo),
+ pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo1),
+ pred_info_set_class_context(PredInfo1, Constraints, PredInfo).
:- pred lambda__process_goal(hlds_goal, hlds_goal,
lambda_info, lambda_info).
@@ -190,6 +199,9 @@
lambda__process_goal_2(higher_order_call(A,B,C,D,E,F), GoalInfo,
higher_order_call(A,B,C,D,E,F) - GoalInfo) -->
[].
+lambda__process_goal_2(class_method_call(A,B,C,D,E,F), GoalInfo,
+ class_method_call(A,B,C,D,E,F) - GoalInfo) -->
+ [].
lambda__process_goal_2(call(A,B,C,D,E,F), GoalInfo,
call(A,B,C,D,E,F) - GoalInfo) -->
[].
@@ -224,18 +236,18 @@
lambda__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals0, LambdaGoal,
Unification0, Functor, Unification, LambdaInfo0, LambdaInfo) :-
- LambdaInfo0 = lambda_info(VarSet, VarTypes, TVarSet, TVarMap,
- POF, PredName, ModuleInfo0),
+ LambdaInfo0 = lambda_info(VarSet, VarTypes, Constraints, TVarSet,
+ TVarMap, TCVarMap, POF, PredName, ModuleInfo0),
lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
OrigNonLocals0, LambdaGoal, Unification0, VarSet, VarTypes,
- TVarSet, TVarMap, ModuleInfo0, Functor,
+ Constraints, TVarSet, TVarMap, TCVarMap, ModuleInfo0, Functor,
Unification, ModuleInfo),
- LambdaInfo = lambda_info(VarSet, VarTypes, TVarSet, TVarMap,
- POF, PredName, ModuleInfo).
+ LambdaInfo = lambda_info(VarSet, VarTypes, Constraints, TVarSet,
+ TVarMap, TCVarMap, POF, PredName, ModuleInfo).
lambda__transform_lambda(PredOrFunc, OrigPredName, Vars, Modes, Detism,
OrigNonLocals0, LambdaGoal, Unification0, VarSet, VarTypes,
- TVarSet, TVarMap, ModuleInfo0, Functor,
+ Constraints, TVarSet, TVarMap, TCVarMap, ModuleInfo0, Functor,
Unification, ModuleInfo) :-
(
Unification0 = construct(Var0, _, _, UniModes0)
@@ -360,11 +372,11 @@
proc_info_create(VarSet, VarTypes, PermutedArgVars,
PermutedArgModes, Detism, LambdaGoal, LambdaContext,
- TVarMap, ProcInfo),
+ TVarMap, TCVarMap, ProcInfo),
pred_info_create(ModuleName, PredName, TVarSet, ArgTypes,
- true, LambdaContext, local, [], PredOrFunc, ProcInfo,
- ProcId, PredInfo),
+ true, LambdaContext, local, [], PredOrFunc,
+ Constraints, ProcInfo, ProcId, PredInfo),
% save the new predicate in the predicate table
Index: compiler/lco.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/lco.m,v
retrieving revision 1.7
diff -u -r1.7 lco.m
--- lco.m 1997/09/01 14:02:49 1.7
+++ lco.m 1997/09/08 04:54:11
@@ -83,6 +83,9 @@
lco_in_goal_2(higher_order_call(A,B,C,D,E,F), _ModuleInfo,
higher_order_call(A,B,C,D,E,F)).
+lco_in_goal_2(class_method_call(A,B,C,D,E,F), _ModuleInfo,
+ class_method_call(A,B,C,D,E,F)).
+
lco_in_goal_2(call(A,B,C,D,E,F), _ModuleInfo, call(A,B,C,D,E,F)).
lco_in_goal_2(unify(A,B,C,D,E), _ModuleInfo, unify(A,B,C,D,E)).
Index: compiler/live_vars.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/live_vars.m,v
retrieving revision 1.67
diff -u -r1.67 live_vars.m
--- live_vars.m 1997/09/01 14:02:55 1.67
+++ live_vars.m 1997/09/08 04:55:25
@@ -254,6 +254,44 @@
ResumeVars = ResumeVars0
).
+ % Code duplication. Ulch.
+build_live_sets_in_goal_2(class_method_call(_, _, ArgVars, Types, Modes, Det),
+ Liveness, ResumeVars0, LiveSets0,
+ GoalInfo, ModuleInfo, ProcInfo,
+ Liveness, ResumeVars, LiveSets) :-
+ % The variables which need to be saved onto the stack
+ % before the call are all the variables that are live
+ % after the call, except for the output arguments produced
+ % by the call, plus all the variables that may be needed
+ % at an enclosing resumption point.
+
+ % To figure out which variables are output, we use the arg_info;
+ % but it shouldn't matter which arg convention we're using,
+ % so we can just pass convention `simple' to make_arg_infos.
+
+ determinism_to_code_model(Det, CallModel),
+ make_arg_infos(simple, Types, Modes, CallModel, ModuleInfo, ArgInfos),
+ find_output_vars_from_arg_info(ArgVars, ArgInfos, OutVars),
+ set__difference(Liveness, OutVars, InputLiveness),
+ set__union(InputLiveness, ResumeVars0, StackVars0),
+
+ % Might need to add more live variables with accurate GC.
+
+ maybe_add_accurate_gc_typeinfos(ModuleInfo, ProcInfo,
+ OutVars, StackVars0, StackVars),
+
+ set__insert(LiveSets0, StackVars, LiveSets),
+
+ % If this is a nondet call, then all the stack slots we need
+ % must be protected against reuse in following code.
+
+ goal_info_get_code_model(GoalInfo, CodeModel),
+ ( CodeModel = model_non ->
+ ResumeVars = StackVars % includes ResumeVars0
+ ;
+ ResumeVars = ResumeVars0
+ ).
+
build_live_sets_in_goal_2(call(PredId, ProcId, ArgVars, BuiltinState, _, _),
Liveness, ResumeVars0, LiveSets0,
GoalInfo, ModuleInfo, ProcInfo,
Index: compiler/livemap.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/livemap.m,v
retrieving revision 1.27
diff -u -r1.27 livemap.m
--- livemap.m 1997/08/25 17:48:18 1.27
+++ livemap.m 1997/09/08 04:12:41
@@ -362,6 +362,9 @@
livemap__special_code_addr(do_det_closure, no).
livemap__special_code_addr(do_semidet_closure, no).
livemap__special_code_addr(do_nondet_closure, no).
+livemap__special_code_addr(do_det_class_method, no).
+livemap__special_code_addr(do_semidet_class_method, no).
+livemap__special_code_addr(do_nondet_class_method, no).
livemap__special_code_addr(do_not_reached, no).
%-----------------------------------------------------------------------------%
Index: compiler/liveness.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/liveness.m,v
retrieving revision 1.84
diff -u -r1.84 liveness.m
--- liveness.m 1997/10/20 07:35:22 1.84
+++ liveness.m 1997/11/17 02:38:55
@@ -289,6 +289,9 @@
detect_liveness_in_goal_2(higher_order_call(_,_,_,_,_,_), _, _, _, _, _) :-
error("higher-order-call in detect_liveness_in_goal_2").
+detect_liveness_in_goal_2(class_method_call(_,_,_,_,_,_), _, _, _, _, _) :-
+ error("class method call in detect_liveness_in_goal_2").
+
detect_liveness_in_goal_2(call(_,_,_,_,_,_), _, _, _, _, _) :-
error("call in detect_liveness_in_goal_2").
@@ -465,6 +468,9 @@
detect_deadness_in_goal_2(higher_order_call(_,_,_,_,_,_), _, _, _, _, _) :-
error("higher-order-call in detect_deadness_in_goal_2").
+detect_deadness_in_goal_2(class_method_call(_,_,_,_,_,_), _, _, _, _, _) :-
+ error("class-method-call in detect_deadness_in_goal_2").
+
detect_deadness_in_goal_2(call(_,_,_,_,_,_), _, _, _, _, _) :-
error("call in detect_deadness_in_goal_2").
@@ -659,6 +665,9 @@
detect_resume_points_in_goal_2(higher_order_call(A,B,C,D,E,F), _, Liveness,
_, _, higher_order_call(A,B,C,D,E,F), Liveness).
+
+detect_resume_points_in_goal_2(class_method_call(A,B,C,D,E,F), _, Liveness, _,
+ _, class_method_call(A,B,C,D,E,F), Liveness).
detect_resume_points_in_goal_2(call(A,B,C,D,E,F), _, Liveness, _, _,
call(A,B,C,D,E,F), Liveness).
Index: compiler/llds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/llds.m,v
retrieving revision 1.212
diff -u -r1.212 llds.m
--- llds.m 1997/11/08 13:11:26 1.212
+++ llds.m 1997/11/17 06:22:12
@@ -16,7 +16,7 @@
:- interface.
-:- import_module hlds_pred, tree, prog_data, (inst).
+:- import_module hlds_pred, hlds_data, tree, prog_data, (inst).
:- import_module assoc_list, bool, list, set, term, std_util.
%-----------------------------------------------------------------------------%
@@ -438,6 +438,9 @@
---> common(int)
; base_type(base_data, string, arity)
% base_data, type name, type arity
+ ; base_typeclass_info(class_id, string)
+ % class name & class arity, names and arities of the
+ % types
; stack_layout(label).
% stack_layout for a given label
@@ -523,6 +526,9 @@
; do_det_closure
; do_semidet_closure
; do_nondet_closure
+ ; do_det_class_method
+ ; do_semidet_class_method
+ ; do_nondet_class_method
; do_not_reached. % we should never jump to this address
% A proc_label is a label used for the entry point to a procedure.
Index: compiler/llds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/llds_out.m,v
retrieving revision 1.62
diff -u -r1.62 llds_out.m
--- llds_out.m 1997/11/11 05:27:50 1.62
+++ llds_out.m 1997/11/18 03:33:09
@@ -17,7 +17,7 @@
:- interface.
-:- import_module llds.
+:- import_module llds, hlds_data.
:- import_module io.
% Given a 'c_file' structure, open the appropriate .c file
@@ -92,6 +92,11 @@
:- pred llds_out__make_base_type_name(base_data, string, arity, string).
:- mode llds_out__make_base_type_name(in, in, in, out) is det.
+ % Create a name for base_typeclass_info
+
+:- pred llds_out__make_base_typeclass_info_name(class_id, string, string).
+:- mode llds_out__make_base_typeclass_info_name(in, in, out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -1820,6 +1825,9 @@
need_code_addr_decls(do_det_closure, yes) --> [].
need_code_addr_decls(do_semidet_closure, yes) --> [].
need_code_addr_decls(do_nondet_closure, yes) --> [].
+need_code_addr_decls(do_det_class_method, yes) --> [].
+need_code_addr_decls(do_semidet_class_method, yes) --> [].
+need_code_addr_decls(do_nondet_class_method, yes) --> [].
need_code_addr_decls(do_not_reached, yes) --> [].
:- pred output_code_addr_decls(code_addr, io__state, io__state).
@@ -1859,6 +1867,12 @@
io__write_string("Declare_entry(do_call_semidet_closure);\n").
output_code_addr_decls(do_nondet_closure) -->
io__write_string("Declare_entry(do_call_nondet_closure);\n").
+output_code_addr_decls(do_det_class_method) -->
+ io__write_string("Declare_entry(do_call_det_class_method);\n").
+output_code_addr_decls(do_semidet_class_method) -->
+ io__write_string("Declare_entry(do_call_semidet_class_method);\n").
+output_code_addr_decls(do_nondet_class_method) -->
+ io__write_string("Declare_entry(do_call_nondet_class_method);\n").
output_code_addr_decls(do_not_reached) -->
io__write_string("Declare_entry(do_not_reached);\n").
@@ -2022,6 +2036,18 @@
io__write_string("tailcall(ENTRY(do_call_nondet_closure),\n\t\t"),
output_label_as_code_addr(CallerLabel),
io__write_string(");\n").
+output_goto(do_det_class_method, CallerLabel) -->
+ io__write_string("tailcall(ENTRY(do_call_det_class_method),\n\t\t"),
+ output_label_as_code_addr(CallerLabel),
+ io__write_string(");\n").
+output_goto(do_semidet_class_method, CallerLabel) -->
+ io__write_string("tailcall(ENTRY(do_call_semidet_class_method),\n\t\t"),
+ output_label_as_code_addr(CallerLabel),
+ io__write_string(");\n").
+output_goto(do_nondet_class_method, CallerLabel) -->
+ io__write_string("tailcall(ENTRY(do_call_nondet_class_method),\n\t\t"),
+ output_label_as_code_addr(CallerLabel),
+ io__write_string(");\n").
output_goto(do_not_reached, CallerLabel) -->
io__write_string("tailcall(ENTRY(do_not_reached),\n\t\t"),
output_label_as_code_addr(CallerLabel),
@@ -2093,6 +2119,12 @@
io__write_string("ENTRY(do_call_semidet_closure)").
output_code_addr(do_nondet_closure) -->
io__write_string("ENTRY(do_call_nondet_closure)").
+output_code_addr(do_det_class_method) -->
+ io__write_string("ENTRY(do_call_det_class_method)").
+output_code_addr(do_semidet_class_method) -->
+ io__write_string("ENTRY(do_call_semidet_class_method)").
+output_code_addr(do_nondet_class_method) -->
+ io__write_string("ENTRY(do_call_nondet_class_method)").
output_code_addr(do_not_reached) -->
io__write_string("ENTRY(do_not_reached)").
@@ -2119,6 +2151,17 @@
io__write_string("__"),
io__write_string(Str)
;
+ % We don't want to include the module name as part
+ % of the name if it is a base_typeclass_info, since
+ % we _want_ to cause a link error for overlapping
+ % instance decls, even if they are in a different
+ % module
+ { VarName = base_typeclass_info(ClassId, TypeNames) },
+ { llds_out__make_base_typeclass_info_name(ClassId, TypeNames,
+ Str) },
+ io__write_string("__"),
+ io__write_string(Str)
+ ;
{ VarName = stack_layout(Label) },
io__write_string("_stack_layout__"),
output_label(Label)
@@ -3032,6 +3075,22 @@
string__append_list(["base_type_", BaseString, "_", TypeName, "_",
A_str], Str).
+
+%-----------------------------------------------------------------------------%
+
+llds_out__make_base_typeclass_info_name(class_id(ClassSym, ClassArity),
+ TypeNames0, Str) :-
+ (
+ ClassSym = unqualified(_),
+ error("llds_out__make_base_typeclass_info_name: unqualified name")
+ ;
+ ClassSym = qualified(ModuleName, ClassName),
+ string__append_list([ModuleName, "__", ClassName], ClassString)
+ ),
+ string__int_to_string(ClassArity, A_str),
+ llds_out__name_mangle(TypeNames0, TypeNames),
+ string__append_list(["base_typeclass_info_", ClassString, "_", A_str,
+ "__", TypeNames], Str).
%-----------------------------------------------------------------------------%
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.243
diff -u -r1.243 make_hlds.m
--- make_hlds.m 1997/11/02 12:28:53 1.243
+++ make_hlds.m 1997/11/17 02:39:04
@@ -133,8 +133,8 @@
% for a predicate to syntactically precede the pred declaration.
%
% Adding default modes for functions needs to come after we have
- % have processed all the mode declarations, since otherwise we
- % can't be sure that there isn't a mode declaration for the function.
+ % processed all the mode declarations, since otherwise we can't be
+ % sure that there isn't a mode declaration for the function.
:- pred add_item_list_decls_pass_2(item_list, item_status,
module_info, module_info, io__state, io__state).
@@ -188,26 +188,29 @@
module_add_mode_defn(Module0, VarSet, ModeDefn, Cond, Context,
Status, Module).
-add_item_decl_pass_1(pred(VarSet, PredName, TypesAndModes, MaybeDet, Cond),
+add_item_decl_pass_1(pred(VarSet, PredName, TypesAndModes,
+ MaybeDet, Cond, ClassContext),
Context, Status, Module0, Status, Module) -->
module_add_pred(Module0, VarSet, PredName, TypesAndModes, MaybeDet,
- Cond, Context, Status, Module).
+ Cond, ClassContext, [], Context, Status, _, Module).
add_item_decl_pass_1(func(VarSet, FuncName, TypesAndModes, RetTypeAndMode,
- MaybeDet, Cond), Context, Status, Module0, Status, Module) -->
+ MaybeDet, Cond, ClassContext), Context, Status, Module0,
+ Status, Module) -->
module_add_func(Module0, VarSet, FuncName, TypesAndModes,
- RetTypeAndMode, MaybeDet, Cond, Context, Status, Module).
+ RetTypeAndMode, MaybeDet, Cond, ClassContext, [], Context,
+ Status, _, Module).
add_item_decl_pass_1(pred_mode(VarSet, PredName, Modes, MaybeDet, Cond),
Context, Status, Module0, Status, Module) -->
module_add_mode(Module0, VarSet, PredName, Modes, MaybeDet, Cond,
- Context, predicate, Module).
+ Context, predicate, _, Module).
add_item_decl_pass_1(func_mode(VarSet, FuncName, Modes, RetMode, MaybeDet,
Cond), Context, Status, Module0, Status, Module) -->
{ list__append(Modes, [RetMode], Modes1) },
module_add_mode(Module0, VarSet, FuncName, Modes1,
- MaybeDet, Cond, Context, function, Module).
+ MaybeDet, Cond, Context, function, _, Module).
add_item_decl_pass_1(pragma(_), _, Status, Module, Status, Module) --> [].
@@ -248,6 +251,16 @@
add_item_decl_pass_1(nothing, _, Status, Module, Status, Module) --> [].
+add_item_decl_pass_1(typeclass(Constraints, Name, Vars, Interface, VarSet),
+ Context, Status, Module0, Status, Module) -->
+ module_add_class_defn(Module0, Constraints, Name, Vars, Interface,
+ VarSet, Context, Status, Module).
+
+ % We add instance declarations on the second pass so that we don't add
+ % an instance declaration before its class declaration.
+add_item_decl_pass_1(instance(_, _, _, _, _), _, Status, Module, Status,
+ Module) --> [].
+
%-----------------------------------------------------------------------------%
% dispatch on the different types of items
@@ -463,8 +476,8 @@
).
add_item_decl_pass_2(func(_VarSet, FuncName, TypesAndModes, _RetTypeAndMode,
- _MaybeDet, _Cond), _Context, Status, Module0, Status, Module)
- -->
+ _MaybeDet, _Cond, _ClassContext), _Context, Status, Module0,
+ Status, Module) -->
%
% add default modes for function declarations, if necessary
%
@@ -490,13 +503,20 @@
--> [].
add_item_decl_pass_2(mode_defn(_, _, _), _, Status, Module, Status, Module)
--> [].
-add_item_decl_pass_2(pred(_, _, _, _, _), _, Status, Module, Status, Module)
+add_item_decl_pass_2(pred(_, _, _, _, _, _), _, Status, Module, Status, Module)
--> [].
add_item_decl_pass_2(pred_mode(_, _, _, _, _), _, Status, Module, Status,
Module) --> [].
add_item_decl_pass_2(func_mode(_, _, _, _, _, _), _, Status, Module, Status,
Module) --> [].
add_item_decl_pass_2(nothing, _, Status, Module, Status, Module) --> [].
+add_item_decl_pass_2(typeclass(_, _, _, _, _)
+ , _, Status, Module, Status, Module) --> [].
+add_item_decl_pass_2(instance(Constraints, Name, Types, Interface, VarSet),
+ Context, Status, Module0, Status, Module) -->
+ { Status = item_status(ImportStatus, _) },
+ module_add_instance_defn(Module0, Constraints, Name, Types, Interface,
+ VarSet, ImportStatus, Context, Module).
%------------------------------------------------------------------------------
@@ -539,9 +559,9 @@
Module, Module, Info, Info) --> [].
add_item_clause(mode_defn(_, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
-add_item_clause(pred(_, _, _, _, _), Status, Status, _,
+add_item_clause(pred(_, _, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
-add_item_clause(func(_, _, _, _, _, _), Status, Status, _,
+add_item_clause(func(_, _, _, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
add_item_clause(pred_mode(_, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
@@ -588,6 +608,10 @@
{ Info = Info0 }
).
add_item_clause(nothing, Status, Status, _, Module, Module, Info, Info) --> [].
+add_item_clause(typeclass(_, _, _, _, _)
+ , Status, Status, _, Module, Module, Info, Info) --> [].
+add_item_clause(instance(_, _, _, _, _)
+ , Status, Status, _, Module, Module, Info, Info) --> [].
%-----------------------------------------------------------------------------%
@@ -1060,12 +1084,16 @@
%---------------------------------------------------------------------------%
:- pred module_add_pred(module_info, varset, sym_name, list(type_and_mode),
- maybe(determinism), condition, term__context,
- item_status, module_info, io__state, io__state).
-:- mode module_add_pred(in, in, in, in, in, in, in, in, out, di, uo) is det.
+ maybe(determinism), condition, list(class_constraint),
+ list(marker_status), term__context, item_status,
+ maybe(pair(pred_id, proc_id)), module_info,
+ io__state, io__state).
+:- mode module_add_pred(in, in, in, in, in, in, in, in, in, in, out, out,
+ di, uo) is det.
module_add_pred(Module0, VarSet, PredName, TypesAndModes, MaybeDet, Cond,
- Context, item_status(Status, NeedQual), Module) -->
+ ClassContext, Markers, Context, item_status(Status, NeedQual),
+ MaybePredProcId, Module) -->
% Only preds with opt_imported clauses are tagged as opt_imported, so
% that the compiler doesn't look for clauses for other preds read in
% from optimization interfaces.
@@ -1075,25 +1103,30 @@
DeclStatus = Status
},
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
- add_new_pred(Module0, VarSet, PredName, Types, Cond, Context,
- DeclStatus, NeedQual, predicate, Module1),
+ add_new_pred(Module0, VarSet, PredName, Types, Cond, ClassContext,
+ Markers, Context, DeclStatus, NeedQual, predicate, Module1),
(
{ MaybeModes = yes(Modes) }
->
module_add_mode(Module1, VarSet, PredName, Modes, MaybeDet,
- Cond, Context, predicate, Module)
+ Cond, Context, predicate, PredProcId, Module),
+ { MaybePredProcId = yes(PredProcId) }
;
- { Module = Module1 }
+ { Module = Module1 },
+ { MaybePredProcId = no }
).
:- pred module_add_func(module_info, varset, sym_name, list(type_and_mode),
- type_and_mode, maybe(determinism), condition, term__context,
- item_status, module_info, io__state, io__state).
-:- mode module_add_func(in, in, in, in, in, in, in, in, in, out, di, uo) is det.
+ type_and_mode, maybe(determinism), condition,
+ list(class_constraint), list(marker_status), term__context,
+ item_status, maybe(pair(pred_id, proc_id)),
+ module_info, io__state, io__state).
+:- mode module_add_func(in, in, in, in, in, in, in, in, in, in, in, out, out,
+ di, uo) is det.
module_add_func(Module0, VarSet, FuncName, TypesAndModes, RetTypeAndMode,
- MaybeDet, Cond, Context,
- item_status(Status, NeedQual), Module) -->
+ MaybeDet, Cond, ClassContext, Markers, Context,
+ item_status(Status, NeedQual), MaybePredProcId, Module) -->
% Only funcs with opt_imported clauses are tagged as opt_imported, so
% that the compiler doesn't look for clauses for other preds.
{ Status = opt_imported ->
@@ -1104,30 +1137,160 @@
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
{ split_type_and_mode(RetTypeAndMode, RetType, MaybeRetMode) },
{ list__append(Types, [RetType], Types1) },
- add_new_pred(Module0, VarSet, FuncName, Types1, Cond, Context,
- DeclStatus, NeedQual, function, Module1),
+ add_new_pred(Module0, VarSet, FuncName, Types1, Cond, ClassContext,
+ Markers, Context, DeclStatus, NeedQual, function, Module1),
(
{ MaybeModes = yes(Modes) },
{ MaybeRetMode = yes(RetMode) }
->
{ list__append(Modes, [RetMode], Modes1) },
module_add_mode(Module1, VarSet, FuncName, Modes1,
- MaybeDet, Cond, Context, function, Module)
+ MaybeDet, Cond, Context, function, PredProcId, Module),
+ { MaybePredProcId = yes(PredProcId) }
+ ;
+ { Module = Module1 },
+ { MaybePredProcId = no}
+ ).
+
+:- pred module_add_class_defn(module_info, list(class_constraint), sym_name,
+ list(var), class_interface, varset, term__context,
+ item_status, module_info, io__state, io__state).
+:- mode module_add_class_defn(in, in, in, in, in, in, in, in, out,
+ di, uo) is det.
+
+module_add_class_defn(Module0, Constraints, Name, Vars, Interface, VarSet,
+ Context, Status, Module) -->
+ { module_info_classes(Module0, Classes0) },
+ { list__length(Vars, ClassArity) },
+ { Key = class_id(Name, ClassArity) },
+ (
+ { map__search(Classes0, Key, _) }
+ ->
+ % XXX format the output properly (?)
+ prog_out__write_context(Context),
+ io__write_string("Error: typeclass "),
+ prog_out__write_sym_name(Name),
+ io__write_char('/'),
+ io__write_int(ClassArity),
+ io__write_string(" multiply defined.\n"),
+ io__set_exit_status(1),
+ { Module = Module0 }
+ ;
+ module_add_class_interface(Module0, Name, Vars, Interface,
+ Status, PredProcIds0, Module1),
+ % Get rid of the `no's from the list of maybes
+ { IsYes = lambda([Maybe::in, PredProcId::out] is semidet,
+ (
+ Maybe = yes(Pred - Proc),
+ PredProcId = hlds_class_proc(Pred, Proc)
+ )) },
+ { list__filter_map(IsYes, PredProcIds0, PredProcIds) },
+ { Value = hlds_class_defn(Constraints, Vars, PredProcIds,
+ VarSet) },
+ { map__det_insert(Classes0, Key, Value, Classes) },
+ { module_info_set_classes(Module1, Classes, Module2) },
+ % When we find the class declaration, make an
+ % entry for the instances.
+ { module_info_instances(Module2, Instances0) },
+ { map__det_insert(Instances0, Key, [], Instances) },
+ { module_info_set_instances(Module2, Instances, Module) }
+ ).
+
+:- pred module_add_class_interface(module_info, sym_name, list(var),
+ class_interface, item_status, list(maybe(pair(pred_id, proc_id))),
+ module_info, io__state, io__state).
+:- mode module_add_class_interface(in, in, in, in, in, out, out, di, uo) is det.
+
+module_add_class_interface(Module, _, _, [], _, [], Module) --> [].
+module_add_class_interface(Module0, Name, Vars, [M|Ms], Status, [P|Ps],
+ Module) -->
+ module_add_class_method(M, Name, Vars, Status, P, Module0, Module1),
+ module_add_class_interface(Module1, Name, Vars, Ms, Status, Ps, Module).
+
+:- pred module_add_class_method(class_method, sym_name, list(var),
+ item_status, maybe(pair(pred_id, proc_id)), module_info, module_info,
+ io__state, io__state).
+:- mode module_add_class_method(in, in, in, in, out, in, out, di, uo) is det.
+
+module_add_class_method(Method, Name, Vars, Status, MaybePredIdProcId,
+ Module0, Module) -->
+ (
+ { Method = pred(VarSet, PredName, TypesAndModes,
+ MaybeDet, Cond, ClassContext, Context) },
+ { term__var_list_to_term_list(Vars, VarTerms) },
+ { NewClassContext = [constraint(Name, VarTerms)|ClassContext] },
+ { Markers = [request(class_method)] },
+ module_add_pred(Module0, VarSet, PredName, TypesAndModes,
+ MaybeDet, Cond, NewClassContext, Markers,
+ Context, Status, MaybePredIdProcId, Module)
+ ;
+ { Method = func(VarSet, FuncName, TypesAndModes, RetTypeAndMode,
+ MaybeDet, Cond, ClassContext, Context) },
+ { term__var_list_to_term_list(Vars, VarTerms) },
+ { NewClassContext = [constraint(Name, VarTerms)|ClassContext] },
+ { Markers = [request(class_method)] },
+ module_add_func(Module0, VarSet, FuncName, TypesAndModes,
+ RetTypeAndMode, MaybeDet, Cond, NewClassContext,
+ Markers, Context, Status, MaybePredIdProcId, Module)
+ ;
+ { Method = pred_mode(VarSet, PredName, Modes, MaybeDet,
+ Cond, Context) },
+ module_add_mode(Module0, VarSet, PredName, Modes, MaybeDet,
+ Cond, Context, predicate, PredIdProcId, Module),
+ { MaybePredIdProcId = yes(PredIdProcId) }
+ ;
+ { Method = func_mode(VarSet, FuncName, Modes, RetMode, MaybeDet,
+ Cond, Context) },
+ { list__append(Modes, [RetMode], Modes1) },
+ module_add_mode(Module0, VarSet, FuncName, Modes1,
+ MaybeDet, Cond, Context, function, PredIdProcId,
+ Module),
+ { MaybePredIdProcId = yes(PredIdProcId) }
+ ).
+
+:- pred module_add_instance_defn(module_info, list(class_constraint), sym_name,
+ list(type), instance_interface, varset, import_status, term__context,
+ module_info, io__state, io__state).
+:- mode module_add_instance_defn(in, in, in, in, in, in, in, in, out,
+ di, uo) is det.
+
+module_add_instance_defn(Module0, Constraints, Name, Types, Interface, VarSet,
+ Status, _Context, Module) -->
+ { module_info_classes(Module0, Classes) },
+ { module_info_instances(Module0, Instances0) },
+ { list__length(Types, ClassArity) },
+ { Key = class_id(Name, ClassArity) },
+ (
+ { map__search(Classes, Key, _) }
+ ->
+ { map__init(Empty) },
+ { NewValue = hlds_instance_defn(Status, Constraints, Types,
+ Interface, no, VarSet, Empty) },
+ { map__lookup(Instances0, Key, Values) },
+ { map__det_update(Instances0, Key, [NewValue|Values],
+ Instances) },
+ { module_info_set_instances(Module0, Instances, Module) }
;
- { Module = Module1 }
+ % XXX give an error since the class has not been
+ % XXX defined
+ { Module = Module0 }
).
+%-----------------------------------------------------------------------------%
+
:- pred add_new_pred(module_info, tvarset, sym_name, list(type), condition,
- term__context, import_status, need_qualifier, pred_or_func,
+ list(class_constraint), list(marker_status), term__context,
+ import_status, need_qualifier, pred_or_func,
module_info, io__state, io__state).
-:- mode add_new_pred(in, in, in, in, in, in, in, in, in, out, di, uo) is det.
+:- mode add_new_pred(in, in, in, in, in, in, in, in, in, in, in, out,
+ di, uo) is det.
% NB. Predicates are also added in polymorphism.m, which converts
% lambda expressions into separate predicates, so any changes may need
% to be reflected there too.
-add_new_pred(Module0, TVarSet, PredName, Types, Cond, Context,
- Status, NeedQual, PredOrFunc, Module) -->
+add_new_pred(Module0, TVarSet, PredName, Types, Cond, ClassContext, Markers,
+ Context, Status, NeedQual, PredOrFunc, Module) -->
{ module_info_name(Module0, ModuleName) },
{ list__length(Types, Arity) },
(
@@ -1141,9 +1304,11 @@
{ Module1 = Module0 },
{ module_info_get_predicate_table(Module1, PredicateTable0) },
{ clauses_info_init(Arity, ClausesInfo) },
+ { map__init(Proofs) },
{ pred_info_init(ModuleName, PredName, Arity, TVarSet, Types,
- Cond, Context, ClausesInfo, Status, [], none,
- PredOrFunc, PredInfo0) },
+ Cond, Context, ClausesInfo, Status, Markers,
+ none, PredOrFunc, ClassContext, Proofs,
+ PredInfo0) },
(
{ predicate_table_search_pf_m_n_a(PredicateTable0,
PredOrFunc, MNameOfPred, PName, Arity,
@@ -1321,8 +1486,12 @@
Cond = true,
clauses_info_init(Arity, ClausesInfo0),
adjust_special_pred_status(Status0, SpecialPredId, Status),
+ map__init(Proofs),
+ % XXX When we have "comparable" or "unifiable" typeclasses,
+ % XXX this context might not be empty
pred_info_init(ModuleName, PredName, Arity, TVarSet, ArgTypes, Cond,
- Context, ClausesInfo0, Status, [], none, predicate, PredInfo0),
+ Context, ClausesInfo0, Status, [], none, predicate, [], Proofs,
+ PredInfo0),
ArgLives = no,
add_new_proc(PredInfo0, Arity, ArgModes, yes(ArgModes),
ArgLives, yes(Det), Context, PredInfo, _),
@@ -1379,14 +1548,16 @@
:- pred module_add_mode(module_info, varset, sym_name, list(mode),
maybe(determinism), condition, term__context, pred_or_func,
- module_info, io__state, io__state).
-:- mode module_add_mode(in, in, in, in, in, in, in, in, out, di, uo) is det.
+ pair(pred_id, proc_id), module_info,
+ io__state, io__state).
+:- mode module_add_mode(in, in, in, in, in, in, in, in, out, out,
+ di, uo) is det.
% We should store the mode varset and the mode condition
% in the hlds - at the moment we just ignore those two arguments.
module_add_mode(ModuleInfo0, _VarSet, PredName, Modes, MaybeDet, _Cond,
- MContext, PredOrFunc, ModuleInfo) -->
+ MContext, PredOrFunc, PredProcId, ModuleInfo) -->
% Lookup the pred or func declaration in the predicate table.
% If it's not there (or if it is ambiguous), optionally print a
@@ -1444,11 +1615,12 @@
% isn't the same as an existing one
{ ArgLives = no },
{ add_new_proc(PredInfo0, Arity, Modes, yes(Modes), ArgLives,
- MaybeDet, MContext, PredInfo, _) },
+ MaybeDet, MContext, PredInfo, ProcId) },
{ map__det_update(Preds0, PredId, PredInfo, Preds) },
{ predicate_table_set_preds(PredicateTable1, Preds, PredicateTable) },
{ module_info_set_predicate_table(ModuleInfo0, PredicateTable,
- ModuleInfo) }.
+ ModuleInfo) },
+ { PredProcId = PredId - ProcId }.
% Whenever there is a clause or mode declaration for an undeclared
% predicate, we add an implicit declaration
@@ -1469,8 +1641,13 @@
term__var_list_to_term_list(TypeVars, Types),
Cond = true,
clauses_info_init(Arity, ClausesInfo),
+ map__init(Proofs),
+ % XXX
+ % XXX This is wrong --- the context isn't nec. empty
+ % XXX
pred_info_init(ModuleName, PredName, Arity, TVarSet, Types, Cond,
- Context, ClausesInfo, local, [], none, PredOrFunc, PredInfo0),
+ Context, ClausesInfo, local, [], none, PredOrFunc, [], Proofs,
+ PredInfo0),
pred_info_set_marker_list(PredInfo0, [request(infer_type)], PredInfo),
(
\+ predicate_table_search_pf_sym_arity(PredicateTable0,
@@ -2095,6 +2272,14 @@
PredCallId).
warn_singletons_in_goal_2(higher_order_call(_, Args, _, _, _, _),
+ GoalInfo, QuantVars, VarSet, PredCallId) -->
+ { goal_info_get_nonlocals(GoalInfo, NonLocals) },
+ { goal_info_get_context(GoalInfo, Context) },
+ warn_singletons(Args, NonLocals, QuantVars, VarSet, Context,
+ PredCallId).
+
+ % This code should never be called anyway.
+warn_singletons_in_goal_2(class_method_call(_, _, Args, _, _, _),
GoalInfo, QuantVars, VarSet, PredCallId) -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
{ goal_info_get_context(GoalInfo, Context) },
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_compile.m,v
retrieving revision 1.60
diff -u -r1.60 mercury_compile.m
--- mercury_compile.m 1997/11/08 13:11:34 1.60
+++ mercury_compile.m 1997/11/17 02:39:06
@@ -32,7 +32,8 @@
:- import_module handle_options, prog_io, modules, module_qual, equiv_type.
:- import_module make_hlds, typecheck, modes.
:- import_module switch_detection, cse_detection, det_analysis, unique_modes.
-:- import_module simplify, intermod, trans_opt, bytecode_gen, bytecode.
+:- import_module check_typeclass, simplify, intermod, trans_opt.
+:- import_module bytecode_gen, bytecode.
:- import_module (lambda), polymorphism, termination, higher_order, inlining.
:- import_module dnf, constraint, unused_args, dead_proc_elim, saved_vars.
:- import_module lco, liveness, stratify.
@@ -560,7 +561,7 @@
( { UnsafeToContinue = yes } ->
{ FoundError = yes },
- { HLDS12 = HLDS5 }
+ { HLDS13 = HLDS5 }
;
mercury_compile__detect_switches(HLDS5, Verbose, Stats, HLDS6),
!,
@@ -590,6 +591,11 @@
Verbose, Stats, HLDS11), !,
mercury_compile__maybe_dump_hlds(HLDS11, "11", "simplify"), !,
+ maybe_write_string(Verbose,
+ "% Mode and type checking typeclass instances...\n"),
+ check_typeclass__check_instance_decls(HLDS11, HLDS12,
+ FoundTypeclassError),
+
%
% work out whether we encountered any errors
%
@@ -599,6 +605,7 @@
{ FoundDetError = no },
{ FoundUniqError = no },
{ FoundStratError = no },
+ { FoundTypeclassError = no },
% Strictly speaking, we shouldn't need to check
% the exit status. But the values returned for
% FoundModeError etc. aren't always correct.
@@ -610,18 +617,18 @@
globals__io_lookup_bool_option(
make_optimization_interface, MakeOptInt),
{ Intermod = yes, MakeOptInt = no ->
- intermod__adjust_pred_import_status(HLDS11,
- HLDS12), !
+ intermod__adjust_pred_import_status(HLDS12,
+ HLDS13), !
;
- HLDS12 = HLDS11
+ HLDS13 = HLDS12
}
;
{ FoundError = yes },
- { HLDS12 = HLDS11 }
+ { HLDS13 = HLDS12 }
)
),
- { HLDS20 = HLDS12 },
+ { HLDS20 = HLDS13 },
mercury_compile__maybe_dump_hlds(HLDS20, "20", "front_end").
:- pred mercury_compile__frontend_pass_2_by_preds(module_info, module_info,
Index: compiler/mercury_to_c.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_c.m,v
retrieving revision 1.27
diff -u -r1.27 mercury_to_c.m
--- mercury_to_c.m 1997/09/01 14:03:37 1.27
+++ mercury_to_c.m 1997/09/08 04:56:47
@@ -165,13 +165,14 @@
{ pred_info_context(PredInfo, Context) },
{ pred_info_name(PredInfo, PredName) },
{ pred_info_non_imported_procids(PredInfo, ProcIds) },
+ { pred_info_get_class_context(PredInfo, ClassContext) },
( { ProcIds = [] } ->
[]
;
c_gen_indent(Indent),
io__write_string("/****\n"),
mercury_output_pred_type(TVarSet, unqualified(PredName),
- ArgTypes, no, Context),
+ ArgTypes, no, ClassContext, Context),
{ pred_info_clauses_info(PredInfo, ClausesInfo) },
{ ClausesInfo = clauses_info(VarSet, _VarTypes, _, HeadVars,
@@ -626,6 +627,8 @@
).
c_gen_goal_2(higher_order_call(_, _, _, _, _, _), _, _, _) -->
+ { error("mercury_to_c: higher_order_call not implemented") }.
+c_gen_goal_2(class_method_call(_, _, _, _, _, _), _, _, _) -->
{ error("mercury_to_c: higher_order_call not implemented") }.
c_gen_goal_2(call(PredId, ProcId, ArgVars, _, _, _PredName),
Indent, CGenInfo0, CGenInfo) -->
Index: compiler/mercury_to_goedel.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_goedel.m,v
retrieving revision 1.60
diff -u -r1.60 mercury_to_goedel.m
--- mercury_to_goedel.m 1997/08/22 13:55:25 1.60
+++ mercury_to_goedel.m 1997/09/08 04:12:52
@@ -140,14 +140,16 @@
goedel_output_item(mode_defn(VarSet, ModeDefn, _Cond), Context) -->
goedel_output_mode_defn(VarSet, ModeDefn, Context).
-goedel_output_item(pred(VarSet, PredName, TypesAndModes, _Det, _Cond), Context)
- -->
+ % XXX Should we ignore ClassContext, or give an error?
+goedel_output_item(pred(VarSet, PredName, TypesAndModes, _Det, _Cond,
+ _ClassContext), Context) -->
io__write_string("\n"),
maybe_write_line_number(Context),
goedel_output_pred(VarSet, PredName, TypesAndModes, Context).
+ % XXX Should we ignore ClassContext, or give an error?
goedel_output_item(func(VarSet, PredName, TypesAndModes, RetTypeAndMode, _Det,
- _Cond), Context) -->
+ _Cond, _ClassContext), Context) -->
io__write_string("\n"),
maybe_write_line_number(Context),
goedel_output_func(VarSet, PredName, TypesAndModes, RetTypeAndMode,
@@ -180,6 +182,15 @@
"warning: C header declarations not allowed. Ignoring\n").
goedel_output_item(nothing, _) --> [].
+goedel_output_item(typeclass(_, _, _, _, _), _) -->
+ io__stderr_stream(Stderr),
+ io__write_string(Stderr,
+ "warning: typeclass declarations not allowed. Ignoring\n").
+
+goedel_output_item(instance(_, _, _, _, _), _) -->
+ io__stderr_stream(Stderr),
+ io__write_string(Stderr,
+ "warning: instance declarations not allowed. Ignoring\n").
%-----------------------------------------------------------------------------%
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.119
diff -u -r1.119 mercury_to_mercury.m
--- mercury_to_mercury.m 1997/10/09 09:38:54 1.119
+++ mercury_to_mercury.m 1997/10/15 06:15:53
@@ -23,12 +23,14 @@
:- mode convert_to_mercury(in, in, in, di, uo) is det.
:- pred mercury_output_pred_type(varset, sym_name, list(type),
- maybe(determinism), term__context, io__state, io__state).
-:- mode mercury_output_pred_type(in, in, in, in, in, di, uo) is det.
+ maybe(determinism), list(class_constraint),
+ term__context, io__state, io__state).
+:- mode mercury_output_pred_type(in, in, in, in, in, in, di, uo) is det.
:- pred mercury_output_func_type(varset, sym_name, list(type), type,
- maybe(determinism), term__context, io__state, io__state).
-:- mode mercury_output_func_type(in, in, in, in, in, in, di, uo) is det.
+ maybe(determinism), list(class_constraint),
+ term__context, io__state, io__state).
+:- mode mercury_output_func_type(in, in, in, in, in, in, in, di, uo) is det.
:- pred mercury_output_pred_mode_decl(varset, sym_name, list(mode),
maybe(determinism), term__context, io__state, io__state).
@@ -150,6 +152,10 @@
:- pred mercury_convert_var_name(string, string).
:- mode mercury_convert_var_name(in, out) is det.
+:- pred mercury_output_constraint(varset, class_constraint,
+ io__state, io__state).
+:- mode mercury_output_constraint(in, in, di, uo) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -221,16 +227,18 @@
maybe_output_line_number(Context),
mercury_output_mode_defn(VarSet, ModeDefn, Context).
-mercury_output_item(pred(VarSet, PredName, TypesAndModes, Det, _Cond), Context)
- -->
+mercury_output_item(pred(VarSet, PredName, TypesAndModes, Det, _Cond,
+ ClassContext), Context) -->
maybe_output_line_number(Context),
- mercury_output_pred_decl(VarSet, PredName, TypesAndModes, Det, Context).
+ mercury_output_pred_decl(VarSet, PredName, TypesAndModes, Det,
+ ClassContext, Context, ".\n", ".\n").
mercury_output_item(func(VarSet, PredName, TypesAndModes, RetTypeAndMode, Det,
- _Cond), Context) -->
+ _Cond, ClassContext), Context) -->
maybe_output_line_number(Context),
mercury_output_func_decl(VarSet, PredName, TypesAndModes,
- RetTypeAndMode, Det, Context).
+ RetTypeAndMode, Det, ClassContext, Context,
+ ".\n", ".\n").
mercury_output_item(pred_mode(VarSet, PredName, Modes, MaybeDet, _Cond),
Context) -->
@@ -320,6 +328,141 @@
).
mercury_output_item(nothing, _) --> [].
+mercury_output_item(typeclass(Constraints, ClassName, Vars, Methods,
+ VarSet), _) -->
+ io__write_string(":- typeclass "),
+
+ % We put an extra set of brackets around the class name in
+ % case the name is an operator
+ io__write_char('('),
+ mercury_output_sym_name(ClassName),
+ io__write_char('('),
+ io__write_list(Vars, ", ",
+ lambda([V::in, IO0::di, IO::uo] is det,
+ (
+ varset__lookup_name(VarSet, V, VarName),
+ io__write_string(VarName, IO0, IO)
+ )
+ )
+ ),
+ io__write_char(')'),
+ io__write_char(')'),
+
+ (
+ { Constraints = [] }
+ ;
+ { Constraints = [_|_] },
+ io__write_string(" <= ("),
+ output_class_constraints(Constraints, VarSet),
+ io__write_string(")")
+ ),
+
+ io__write_string(" where [\n"),
+
+ output_class_methods(Methods),
+
+ io__write_string("].\n").
+mercury_output_item(instance(Constraints, ClassName, Types, Methods,
+ VarSet), _) -->
+ io__write_string(":- instance "),
+
+ % We put an extra set of brackets around the class name in
+ % case the name is an operator
+ io__write_char('('),
+ mercury_output_sym_name(ClassName),
+ io__write_char('('),
+ io__write_list(Types, ", ", term_io__write_term(VarSet)),
+ io__write_char(')'),
+ io__write_char(')'),
+
+ (
+ { Constraints = [] }
+ ;
+ { Constraints = [_|_] },
+ io__write_string(" <= ("),
+ output_class_constraints(Constraints, VarSet),
+ io__write_string(")")
+ ),
+
+ io__write_string(" where [\n"),
+
+ output_instance_methods(Methods),
+
+ io__write_string("].\n").
+
+%-----------------------------------------------------------------------------%
+:- pred output_class_constraints(list(class_constraint), varset,
+ io__state, io__state).
+:- mode output_class_constraints(in, in, di, uo) is det.
+
+output_class_constraints(Constraints, VarSet) -->
+ io__write_list(Constraints, ", ", output_class_constraint(VarSet)).
+
+:- pred output_class_constraint(varset, class_constraint, io__state, io__state).
+:- mode output_class_constraint(in, in, di, uo) is det.
+
+output_class_constraint(VarSet, constraint(Name, Types)) -->
+ mercury_output_sym_name(Name),
+ io__write_char('('),
+ io__write_list(Types, ", ", term_io__write_term(VarSet)),
+ io__write_char(')').
+
+:- pred output_class_methods(list(class_method), io__state, io__state).
+:- mode output_class_methods(in, di, uo) is det.
+
+output_class_methods(Methods) -->
+ io__write_list(Methods, ",\n", output_class_method).
+
+:- pred output_class_method(class_method, io__state, io__state).
+:- mode output_class_method(in, di, uo) is det.
+
+output_class_method(Method) -->
+ io__write_string("\t("),
+ (
+ { Method = pred(VarSet, Name, TypesAndModes, Detism,
+ _Condition, ClassContext, Context) },
+ mercury_output_pred_decl(VarSet, Name, TypesAndModes, Detism,
+ ClassContext, Context, "),\n(", "\n")
+ ;
+ { Method = func(VarSet, Name, TypesAndModes, TypeAndMode,
+ Detism, _Condition, ClassContext, Context) },
+ mercury_output_func_decl(VarSet, Name, TypesAndModes,
+ TypeAndMode, Detism, ClassContext, Context,
+ "),\n(", "\n")
+ ;
+ { Method = pred_mode(VarSet, Name, Modes, Detism,
+ _Condition, Context) },
+ mercury_output_pred_mode_decl2(VarSet, Name, Modes, Detism,
+ Context, "\n")
+ ;
+ { Method = func_mode(VarSet, Name, Modes, Mode,
+ Detism, _Condition, Context) },
+ mercury_output_func_mode_decl2(VarSet, Name, Modes,
+ Mode, Detism, Context, "\n")
+ ),
+ io__write_char(')').
+
+:- pred output_instance_methods(instance_interface, io__state, io__state).
+:- mode output_instance_methods(in, di, uo) is det.
+
+output_instance_methods(Methods) -->
+ { OutputMethod = lambda([Method::in, IO0::di, IO::uo] is det,
+ (
+ (
+ Method = func_instance(Name1, Name2, Arity),
+ io__write_string("func((", IO0, IO1)
+ ;
+ Method = pred_instance(Name1, Name2, Arity),
+ io__write_string("pred((", IO0, IO1)
+ ),
+ mercury_output_bracketed_sym_name(Name1, IO1, IO2),
+ io__write_string(")/", IO2, IO3),
+ io__write_int(Arity, IO3, IO4),
+ io__write_string(") is ", IO4, IO5),
+ mercury_output_bracketed_sym_name(Name2, IO5, IO)
+ )
+ ) },
+ io__write_list(Methods, ",\n", OutputMethod).
%-----------------------------------------------------------------------------%
@@ -878,6 +1021,12 @@
{ string__int_to_string(Arity, ArityString) },
io__write_strings(["<base_type_info for ", Module, ":", Type, "/",
ArityString, ">"]).
+mercury_output_cons_id(base_typeclass_info_const(Module, Class, InstanceString),
+ _) -->
+ io__write_string("<base_typeclass_info for "),
+ io__write(Class),
+ io__write_strings([" from module ", Module, ", instance number",
+ InstanceString]).
mercury_output_mode_defn(VarSet, eqv_mode(Name, Args, Mode), Context) -->
io__write_string(":- mode ("),
@@ -1053,23 +1202,39 @@
%-----------------------------------------------------------------------------%
:- pred mercury_output_pred_decl(varset, sym_name, list(type_and_mode),
- maybe(determinism), term__context, io__state, io__state).
-:- mode mercury_output_pred_decl(in, in, in, in, in, di, uo) is det.
+ maybe(determinism), list(class_constraint),
+ term__context, string, string, io__state, io__state).
+:- mode mercury_output_pred_decl(in, in, in, in, in, in, in, in, di, uo) is det.
-mercury_output_pred_decl(VarSet, PredName, TypesAndModes, MaybeDet, Context) -->
+mercury_output_pred_decl(VarSet, PredName, TypesAndModes, MaybeDet,
+ ClassContext, Context, Separator, Terminator) -->
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
- mercury_output_pred_type(VarSet, PredName, Types, MaybeDet, Context),
(
{ MaybeModes = yes(Modes) },
{ Modes \= [] }
->
- mercury_output_pred_mode_decl(VarSet, PredName, Modes,
- MaybeDet, Context)
+ mercury_output_pred_type_2(VarSet, PredName, Types, MaybeDet,
+ ClassContext, Context, Separator),
+ mercury_output_pred_mode_decl2(VarSet, PredName, Modes,
+ MaybeDet, Context, Terminator)
;
- []
+ mercury_output_pred_type_2(VarSet, PredName, Types, MaybeDet,
+ ClassContext, Context, Terminator)
).
-mercury_output_pred_type(VarSet, PredName, Types, MaybeDet, _Context) -->
+mercury_output_pred_type(VarSet, PredName, Types, MaybeDet, ClassContext,
+ Context) -->
+ mercury_output_pred_type_2(VarSet, PredName, Types, MaybeDet,
+ ClassContext, Context, ".\n").
+
+
+:- pred mercury_output_pred_type_2(varset, sym_name, list(type),
+ maybe(determinism), list(class_constraint),
+ term__context, string, io__state, io__state).
+:- mode mercury_output_pred_type_2(in, in, in, in, in, in, in, di, uo) is det.
+
+mercury_output_pred_type_2(VarSet, PredName, Types, MaybeDet, ClassContext,
+ _Context, Separator) -->
io__write_string(":- pred "),
(
{ Types = [Type | Rest] }
@@ -1078,9 +1243,11 @@
io__write_string("("),
mercury_output_term(Type, VarSet, no),
mercury_output_remaining_terms(Rest, VarSet, no),
- io__write_string(")")
+ io__write_string(")"),
+ mercury_output_class_context(ClassContext, VarSet)
;
mercury_output_bracketed_sym_name(PredName),
+ mercury_output_class_context(ClassContext, VarSet),
mercury_output_det_annotation(MaybeDet)
),
@@ -1105,34 +1272,47 @@
;
[]
),
- io__write_string(".\n").
+ io__write_string(Separator).
%-----------------------------------------------------------------------------%
:- pred mercury_output_func_decl(varset, sym_name, list(type_and_mode),
- type_and_mode, maybe(determinism), term__context,
+ type_and_mode, maybe(determinism),
+ list(class_constraint), term__context, string, string,
io__state, io__state).
-:- mode mercury_output_func_decl(in, in, in, in, in, in, di, uo) is det.
+:- mode mercury_output_func_decl(in, in, in, in, in, in, in, in, in,
+ di, uo) is det.
mercury_output_func_decl(VarSet, FuncName, TypesAndModes, RetTypeAndMode,
- MaybeDet, Context) -->
+ MaybeDet, ClassContext, Context, Separator, Terminator) -->
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
{ split_type_and_mode(RetTypeAndMode, RetType, MaybeRetMode) },
(
{ MaybeModes = yes(Modes) },
{ MaybeRetMode = yes(RetMode) }
->
- mercury_output_func_type(VarSet, FuncName, Types, RetType,
- no, Context),
- mercury_output_func_mode_decl(VarSet, FuncName, Modes, RetMode,
- MaybeDet, Context)
+ mercury_output_func_type2(VarSet, FuncName, Types, RetType,
+ no, ClassContext, Context, Separator),
+ mercury_output_func_mode_decl2(VarSet, FuncName, Modes, RetMode,
+ MaybeDet, Context, Terminator)
;
- mercury_output_func_type(VarSet, FuncName, Types, RetType,
- MaybeDet, Context)
+ mercury_output_func_type2(VarSet, FuncName, Types, RetType,
+ MaybeDet, ClassContext, Context, Terminator)
).
-mercury_output_func_type(VarSet, FuncName, Types, RetType, MaybeDet, _Context)
- -->
+mercury_output_func_type(VarSet, FuncName, Types, RetType, MaybeDet,
+ ClassContext, Context) -->
+ mercury_output_func_type2(VarSet, FuncName, Types, RetType, MaybeDet,
+ ClassContext, Context, ".\n").
+
+:- pred mercury_output_func_type2(varset, sym_name, list(type), type,
+ maybe(determinism), list(class_constraint),
+ term__context, string, io__state, io__state).
+:- mode mercury_output_func_type2(in, in, in, in, in, in, in, in,
+ di, uo) is det.
+
+mercury_output_func_type2(VarSet, FuncName, Types, RetType, MaybeDet,
+ ClassContext, _Context, Separator) -->
io__write_string(":- func "),
(
{ Types = [Type | Rest] }
@@ -1147,18 +1327,58 @@
),
io__write_string(" = "),
mercury_output_term(RetType, VarSet, no),
+ mercury_output_class_context(ClassContext, VarSet),
mercury_output_det_annotation(MaybeDet),
- io__write_string(".\n").
+ io__write_string(Separator).
+
+%-----------------------------------------------------------------------------%
+
+:- pred mercury_output_class_context(list(class_constraint), varset,
+ io__state, io__state).
+:- mode mercury_output_class_context(in, in, di, uo) is det.
+
+mercury_output_class_context(ClassContext, VarSet) -->
+ (
+ { ClassContext = [] }
+ ;
+ { ClassContext = [_|_] },
+ io__write_string(" <= ("),
+ io__write_list(ClassContext, ", ",
+ mercury_output_constraint(VarSet)),
+ io__write_char(')')
+ ).
+
+mercury_output_constraint(VarSet, constraint(Name, Types)) -->
+ mercury_output_sym_name(Name),
+ io__write_char('('),
+ io__write_list(Types, ", ", output_type(VarSet)),
+ io__write_char(')').
+
+:- pred output_type(varset, term, io__state, io__state).
+:- mode output_type(in, in, di, uo) is det.
+
+output_type(VarSet, Type) -->
+ mercury_output_term(Type, VarSet, no).
%-----------------------------------------------------------------------------%
% Output a mode declaration for a predicate.
mercury_output_pred_mode_decl(VarSet, PredName, Modes, MaybeDet, Context) -->
+ mercury_output_pred_mode_decl2(VarSet, PredName, Modes, MaybeDet,
+ Context, ".\n").
+
+:- pred mercury_output_pred_mode_decl2(varset, sym_name, list(mode),
+ maybe(determinism), term__context, string,
+ io__state, io__state).
+:- mode mercury_output_pred_mode_decl2(in, in, in, in, in, in, di, uo) is det.
+
+mercury_output_pred_mode_decl2(VarSet, PredName, Modes, MaybeDet, Context,
+ Separator) -->
io__write_string(":- mode "),
mercury_output_pred_mode_subdecl(VarSet, PredName, Modes, MaybeDet,
Context),
- io__write_string(".\n").
+ io__write_string(Separator).
mercury_output_pred_mode_subdecl(VarSet, PredName, Modes, MaybeDet,
_Context) -->
@@ -1178,10 +1398,21 @@
mercury_output_func_mode_decl(VarSet, FuncName, Modes, RetMode, MaybeDet,
Context) -->
+ mercury_output_func_mode_decl2(VarSet, FuncName, Modes, RetMode,
+ MaybeDet, Context, ".\n").
+
+:- pred mercury_output_func_mode_decl2(varset, sym_name, list(mode), mode,
+ maybe(determinism), term__context, string,
+ io__state, io__state).
+:- mode mercury_output_func_mode_decl2(in, in, in, in, in, in, in,
+ di, uo) is det.
+
+mercury_output_func_mode_decl2(VarSet, FuncName, Modes, RetMode, MaybeDet,
+ Context, Separator) -->
io__write_string(":- mode "),
mercury_output_func_mode_subdecl(VarSet, FuncName, Modes, RetMode,
MaybeDet, Context),
- io__write_string(".\n").
+ io__write_string(Separator).
mercury_output_func_mode_subdecl(VarSet, FuncName, Modes, RetMode, MaybeDet,
_Context) -->
Index: compiler/mode_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mode_util.m,v
retrieving revision 1.101
diff -u -r1.101 mode_util.m
--- mode_util.m 1997/09/29 06:45:48 1.101
+++ mode_util.m 1997/10/14 06:59:42
@@ -1126,6 +1126,13 @@
{ instmap_delta_from_mode_list(Vars, Modes,
ModuleInfo, InstMapDelta) }.
+recompute_instmap_delta_2(_, class_method_call(A, B, Vars, C, Modes, D), _,
+ class_method_call(A, B, Vars, C, Modes, D),
+ _InstMap, InstMapDelta) -->
+ =(ModuleInfo),
+ { instmap_delta_from_mode_list(Vars, Modes,
+ ModuleInfo, InstMapDelta) }.
+
recompute_instmap_delta_2(_, call(PredId, ProcId, Args, D, E, F), _,
call(PredId, ProcId, Args, D, E, F), InstMap, InstMapDelta) -->
recompute_instmap_delta_call(PredId, ProcId,
Index: compiler/modes.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modes.m,v
retrieving revision 1.206
diff -u -r1.206 modes.m
--- modes.m 1997/11/13 06:27:07 1.206
+++ modes.m 1997/11/20 05:21:32
@@ -795,6 +795,12 @@
modecheck_higher_order_pred_call(PredVar, Args0, PredOrFunc, GoalInfo0,
Goal).
+ % XXX This should be fixed one day, in case we decide to re-run
+ % modechecking or something like that.
+modecheck_goal_expr(class_method_call(_, _, _, _, _, _),
+ _GoalInfo0, _Goal) -->
+ { error("modecheck_goal_expr: class method exists at modecheck time") }.
+
modecheck_goal_expr(unify(A0, B0, _, UnifyInfo0, UnifyContext), GoalInfo0, Goal)
-->
mode_checkpoint(enter, "unify"),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.24
diff -u -r1.24 module_qual.m
--- module_qual.m 1997/10/09 09:38:57 1.24
+++ module_qual.m 1997/10/15 06:27:37
@@ -97,12 +97,13 @@
type_id_set, % Sets of all types, modes and
inst_id_set, % insts visible in this module.
mode_id_set,
+ class_id_set,
set(module_name), % modules imported in the
% interface that are not definitely
% needed in the interface.
import_status, % import status of the current item.
int, % number of errors found.
- bool, % are there any undefined types.
+ bool, % are there any undefined types or typeclasses.
bool, % are there any undefined insts or modes.
bool, % do we want to report errors.
error_context, % context of the current item.
@@ -131,14 +132,18 @@
add_mode_defn(ModeDefn, Info0, Info).
collect_mq_info_2(module_defn(_, ModuleDefn), Info0, Info) :-
process_module_defn(ModuleDefn, Info0, Info).
-collect_mq_info_2(pred(_,_,_,_,_), Info, Info).
-collect_mq_info_2(func(_,_,_,_,_,_), Info, Info).
+collect_mq_info_2(pred(_,_,_,_,_,_), Info, Info).
+collect_mq_info_2(func(_,_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pred_mode(_,_,_,_,_), Info, Info).
collect_mq_info_2(func_mode(_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pragma(_), Info, Info).
collect_mq_info_2(nothing, Info, Info).
+collect_mq_info_2(typeclass(_, Name, Vars, _, _), Info0, Info) :-
+ add_typeclass_defn(Name, Vars, Info0, Info).
+collect_mq_info_2(instance(_,_,_,_,_), Info, Info).
-% Predicates to add the type, inst and mode ids visible
+
+% Predicates to add the type, inst, mode and typeclass ids visible
% in this module to the mq_info.
:- pred add_type_defn(type_defn::in, mq_info::in, mq_info::out) is det.
@@ -176,6 +181,16 @@
id_set_insert(NeedQualifier, SymName - Arity, Modes0, Modes),
mq_info_set_modes(Info0, Modes, Info).
+:- pred add_typeclass_defn(sym_name::in, list(var)::in,
+ mq_info::in, mq_info::out) is det.
+
+add_typeclass_defn(SymName, Params, Info0, Info) :-
+ list__length(Params, Arity),
+ mq_info_get_classes(Info0, Classes0),
+ mq_info_get_need_qual_flag(Info0, NeedQualifier),
+ id_set_insert(NeedQualifier, SymName - Arity, Classes0, Classes),
+ mq_info_set_classes(Info0, Classes, Info).
+
% Update import status.
% Add imported modules if in the interface.
:- pred process_module_defn(module_defn::in, mq_info::in, mq_info::out) is det.
@@ -258,22 +273,28 @@
module_defn(A, ModuleDefn) - Context, Info0, Info, Continue) -->
{ update_import_status(ModuleDefn, Info0, Info, Continue) }.
-module_qualify_item(pred(A, SymName, TypesAndModes0, D, E) - Context,
- pred(A, SymName, TypesAndModes, D, E) - Context,
+module_qualify_item(
+ pred(A, SymName, TypesAndModes0, D, E, Constraints0) - Context,
+ pred(A, SymName, TypesAndModes, D, E, Constraints) - Context,
Info0, Info, yes) -->
{ list__length(TypesAndModes0, Arity) },
{ mq_info_set_error_context(Info0, pred(SymName - Arity) - Context,
Info1) },
- qualify_types_and_modes(TypesAndModes0, TypesAndModes, Info1, Info).
+ qualify_types_and_modes(TypesAndModes0, TypesAndModes, Info1, Info2),
+ qualify_class_constraints(Constraints0, Constraints, Info2, Info).
-module_qualify_item(func(A,SymName, TypesAndModes0, TypeAndMode0,D,E) - Context,
- func(A, SymName, TypesAndModes, TypeAndMode, D, E) - Context,
+module_qualify_item(
+ func(A,SymName, TypesAndModes0, TypeAndMode0,D,E,Constraints0)
+ - Context,
+ func(A, SymName, TypesAndModes, TypeAndMode, D, E, Constraints)
+ - Context,
Info0, Info, yes) -->
{ list__length(TypesAndModes0, Arity) },
{ mq_info_set_error_context(Info0, func(SymName - Arity) - Context,
Info1) },
qualify_types_and_modes(TypesAndModes0, TypesAndModes, Info1, Info2),
- qualify_type_and_mode(TypeAndMode0, TypeAndMode, Info2, Info).
+ qualify_type_and_mode(TypeAndMode0, TypeAndMode, Info2, Info3),
+ qualify_class_constraints(Constraints0, Constraints, Info3, Info).
module_qualify_item(pred_mode(A, SymName, Modes0, C, D) - Context,
pred_mode(A, SymName, Modes, C, D) - Context,
@@ -298,6 +319,31 @@
qualify_pragma(Pragma0, Pragma, Info1, Info).
module_qualify_item(nothing - Context, nothing - Context,
Info, Info, yes) --> [].
+module_qualify_item(typeclass(Constraints0, Name, Vars, Interface0, VarSet) -
+ Context,
+ typeclass(Constraints, Name, Vars, Interface, VarSet) -
+ Context,
+ Info0, Info, yes) -->
+ { list__length(Vars, Arity) },
+ { Id = Name - Arity },
+ { mq_info_set_error_context(Info0, class(Id) - Context, Info1) },
+ qualify_class_constraints(Constraints0, Constraints, Info1, Info2),
+ qualify_class_interface(Interface0, Interface, Info2, Info).
+
+module_qualify_item(instance(Constraints0, Name0, Types0, Interface0, VarSet) -
+ Context,
+ instance(Constraints, Name, Types, Interface, VarSet) -
+ Context,
+ Info0, Info, yes) -->
+ { list__length(Types0, Arity) },
+ { Id = Name0 - Arity },
+ { mq_info_set_error_context(Info0, instance(Id) - Context, Info1) },
+ % We don't qualify the interface yet, since that requires
+ % us to resolve overloading.
+ qualify_class_constraints(Constraints0, Constraints, Info1, Info2),
+ qualify_classname(Id, Name - _, Info2, Info3),
+ qualify_type_list(Types0, Types, Info3, Info),
+ { qualify_instance_interface(Name, Interface0, Interface) }.
:- pred update_import_status(module_defn::in, mq_info::in, mq_info::out,
bool::out) is det.
@@ -627,11 +673,116 @@
qualify_mode(Mode0, Mode, Info0, Info1),
qualify_pragma_vars(PragmaVars0, PragmaVars, Info1, Info).
+:- pred qualify_class_constraints(list(class_constraint)::in,
+ list(class_constraint)::out, mq_info::in, mq_info::out, io__state::di,
+ io__state::uo) is det.
+
+qualify_class_constraints([], [], MQInfo, MQInfo) --> [].
+qualify_class_constraints([C0|C0s], [C|Cs], MQInfo0, MQInfo) -->
+ qualify_class_constraint(C0, C, MQInfo0, MQInfo1),
+ qualify_class_constraints(C0s, Cs, MQInfo1, MQInfo).
+
+:- pred qualify_class_constraint(class_constraint::in, class_constraint::out,
+ mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
+
+qualify_class_constraint(constraint(ClassName0, Types0),
+ constraint(ClassName, Types), MQInfo0, MQInfo) -->
+ { list__length(Types0, Arity) },
+ qualify_classname(ClassName0 - Arity, ClassName - _, MQInfo0, MQInfo1),
+ qualify_type_list(Types0, Types, MQInfo1, MQInfo).
+
+:- pred qualify_classname(pair(classname, arity)::in,
+ pair(classname, arity)::out, mq_info::in, mq_info::out,
+ io__state::di, io__state::uo) is det.
+
+qualify_classname(Class0, Class, MQInfo0, MQInfo) -->
+ { mq_info_get_classes(MQInfo0, ClassIdSet) },
+ find_unique_match(Class0, Class, ClassIdSet, class_id,
+ MQInfo0, MQInfo).
+
+:- pred qualify_class_interface(class_interface::in, class_interface::out,
+ mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
+
+qualify_class_interface([], [], MQInfo, MQInfo) --> [].
+qualify_class_interface([M0|M0s], [M|Ms], MQInfo0, MQInfo) -->
+ qualify_class_method(M0, M, MQInfo0, MQInfo1),
+ qualify_class_interface(M0s, Ms, MQInfo1, MQInfo).
+
+:- pred qualify_class_method(class_method::in, class_method::out,
+ mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
+
+ % There is no need to qualify the method name, since that is
+ % done when the item is parsed.
+qualify_class_method(
+ pred(Varset, Name, TypesAndModes0, MaybeDet, Cond,
+ ClassContext0, Context),
+ pred(Varset, Name, TypesAndModes, MaybeDet, Cond,
+ ClassContext, Context),
+ MQInfo0, MQInfo
+ ) -->
+ qualify_types_and_modes(TypesAndModes0, TypesAndModes,
+ MQInfo0, MQInfo1),
+ qualify_class_constraints(ClassContext0, ClassContext,
+ MQInfo1, MQInfo).
+qualify_class_method(
+ func(Varset, Name, TypesAndModes0, ReturnMode0, MaybeDet, Cond,
+ ClassContext0, Context),
+ func(Varset, Name, TypesAndModes, ReturnMode, MaybeDet, Cond,
+ ClassContext, Context),
+ MQInfo0, MQInfo
+ ) -->
+ qualify_types_and_modes(TypesAndModes0, TypesAndModes,
+ MQInfo0, MQInfo1),
+ qualify_type_and_mode(ReturnMode0, ReturnMode, MQInfo1, MQInfo2),
+ qualify_class_constraints(ClassContext0, ClassContext,
+ MQInfo2, MQInfo).
+qualify_class_method(
+ pred_mode(Varset, Name, Modes0, MaybeDet, Cond, Context),
+ pred_mode(Varset, Name, Modes, MaybeDet, Cond, Context),
+ MQInfo0, MQInfo
+ ) -->
+ qualify_mode_list(Modes0, Modes, MQInfo0, MQInfo).
+qualify_class_method(
+ func_mode(Varset, Name, Modes0, ReturnMode0, MaybeDet, Cond,
+ Context),
+ func_mode(Varset, Name, Modes, ReturnMode, MaybeDet, Cond,
+ Context),
+ MQInfo0, MQInfo
+ ) -->
+ qualify_mode_list(Modes0, Modes, MQInfo0, MQInfo1),
+ qualify_mode(ReturnMode0, ReturnMode, MQInfo1, MQInfo).
+
+:- pred qualify_instance_interface(sym_name::in, instance_interface::in,
+ instance_interface::out) is det.
+
+qualify_instance_interface(ClassName, M0s, Ms) :-
+ (
+ ClassName = qualified(Module, _)
+ ;
+ ClassName = unqualified( _),
+ Module = ""
+ ),
+ Qualify = lambda([M0::in, M::out] is det,
+ (
+ M0 = pred_instance(unqualified(Method), A, B),
+ M = pred_instance(qualified(Module, Method), A, B)
+ ;
+ M0 = pred_instance(qualified(_, _), _A, _B),
+ M = M0
+ ;
+ M0 = func_instance(unqualified(Method), A, B),
+ M = func_instance(qualified(Module, Method), A, B)
+ ;
+ M0 = func_instance(qualified(_, _), _A, _B),
+ M = M0
+ )),
+ list__map(Qualify, M0s, Ms).
+
% Find the unique match in the current name space for a given id
% from a list of ids. If none exists, either because no match was
% found or mulitiple matches were found, report an error.
- % This predicate assumes that type_ids, inst_ids and mode_ids
- % have the same representation.
+ % This predicate assumes that type_ids, inst_ids, mode_ids and
+ % class_ids have the same representation.
:- pred find_unique_match(id::in, id::out, id_set::in, id_type::in,
mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
@@ -700,7 +851,8 @@
:- type id_type --->
type_id
; mode_id
- ; inst_id.
+ ; inst_id
+ ; class_id.
:- type error_context == pair(error_context2, term__context).
@@ -716,7 +868,9 @@
; func_mode(id)
; (pragma)
; lambda_expr
- ; type_qual.
+ ; type_qual
+ ; class(id)
+ ; instance(id).
% Report an undefined type, inst or mode.
:- pred report_undefined(error_context, pair(sym_name, int),
@@ -800,12 +954,19 @@
io__write_string("pragma").
write_error_context2(type_qual) -->
io__write_string("explicit type qualification").
+write_error_context2(class(Id)) -->
+ io__write_string("declaration of typeclass "),
+ write_id(Id).
+write_error_context2(instance(Id)) -->
+ io__write_string("declaration of instance of typeclass "),
+ write_id(Id).
:- pred id_type_to_string(id_type::in, string::out) is det.
id_type_to_string(type_id, "type").
id_type_to_string(mode_id, "mode").
id_type_to_string(inst_id, "inst").
+id_type_to_string(class_id, "typeclass").
% Write sym_name/arity.
:- pred write_id(id::in, io__state::di, io__state::uo) is det.
@@ -917,12 +1078,13 @@
ErrorContext = type(unqualified("") - 0) - Context,
set__init(InterfaceModules0),
id_set_init(Empty),
- Info0 = mq_info(Empty, Empty, Empty, InterfaceModules0, local, 0,
+ Info0 = mq_info(Empty, Empty, Empty, Empty, InterfaceModules0, local, 0,
no, no, ReportErrors, ErrorContext, may_be_unqualified).
:- pred mq_info_get_types(mq_info::in, type_id_set::out) is det.
:- pred mq_info_get_insts(mq_info::in, inst_id_set::out) is det.
:- pred mq_info_get_modes(mq_info::in, mode_id_set::out) is det.
+:- pred mq_info_get_classes(mq_info::in, class_id_set::out) is det.
:- pred mq_info_get_interface_modules(mq_info::in,
set(module_name)::out) is det.
:- pred mq_info_get_import_status(mq_info::in, import_status::out) is det.
@@ -932,22 +1094,24 @@
:- pred mq_info_get_report_error_flag(mq_info::in, bool::out) is det.
:- pred mq_info_get_error_context(mq_info::in, error_context::out) is det.
-mq_info_get_types(mq_info(Types, _,_,_,_,_,_,_,_,_,_), Types).
-mq_info_get_insts(mq_info(_, Insts, _,_,_,_,_,_,_,_,_), Insts).
-mq_info_get_modes(mq_info(_,_, Modes, _,_,_,_,_,_,_,_), Modes).
-mq_info_get_interface_modules(mq_info(_,_,_, Modules, _,_,_,_,_,_,_), Modules).
-mq_info_get_import_status(mq_info(_,_,_,_, Status, _,_,_,_,_,_), Status).
-mq_info_get_num_errors(mq_info(_,_,_,_,_, NumErrors, _,_,_,_,_), NumErrors).
-mq_info_get_type_error_flag(mq_info(_,_,_,_,_,_, TypeErrs, _,_,_,_), TypeErrs).
-mq_info_get_mode_error_flag(mq_info(_,_,_,_,_,_,_, ModeError, _,_,_),
+mq_info_get_types(mq_info(Types, _, _,_,_,_,_,_,_,_,_,_), Types).
+mq_info_get_insts(mq_info(_, Insts, _,_,_,_,_,_,_,_,_,_), Insts).
+mq_info_get_modes(mq_info(_,_, Modes, _,_,_,_,_,_,_,_,_), Modes).
+mq_info_get_classes(mq_info(_,_,_, Classes, _,_,_,_,_,_,_,_), Classes).
+mq_info_get_interface_modules(mq_info(_,_,_,_, Modules,_,_,_,_,_,_,_), Modules).
+mq_info_get_import_status(mq_info(_,_,_,_,_, Status, _,_,_,_,_,_), Status).
+mq_info_get_num_errors(mq_info(_,_,_,_,_,_, NumErrors, _,_,_,_,_), NumErrors).
+mq_info_get_type_error_flag(mq_info(_,_,_,_,_,_,_, TypeErrs,_,_,_,_), TypeErrs).
+mq_info_get_mode_error_flag(mq_info(_,_,_,_,_,_,_,_, ModeError, _,_,_),
ModeError).
-mq_info_get_report_error_flag(mq_info(_,_,_,_,_,_,_,_, Report,_,_), Report).
-mq_info_get_error_context(mq_info(_,_,_,_,_,_,_,_,_, Context,_), Context).
-mq_info_get_need_qual_flag(mq_info(_,_,_,_,_,_,_,_,_,_,UseModule), UseModule).
+mq_info_get_report_error_flag(mq_info(_,_,_,_,_,_,_,_,_, Report,_,_), Report).
+mq_info_get_error_context(mq_info(_,_,_,_,_,_,_,_,_,_, Context,_), Context).
+mq_info_get_need_qual_flag(mq_info(_,_,_,_,_,_,_,_,_,_,_,UseModule), UseModule).
:- pred mq_info_set_types(mq_info::in, type_id_set::in, mq_info::out) is det.
:- pred mq_info_set_insts(mq_info::in, inst_id_set::in, mq_info::out) is det.
:- pred mq_info_set_modes(mq_info::in, mode_id_set::in, mq_info::out) is det.
+:- pred mq_info_set_classes(mq_info::in, class_id_set::in, mq_info::out) is det.
:- pred mq_info_set_interface_modules(mq_info::in, set(module_name)::in,
mq_info::out) is det.
:- pred mq_info_set_import_status(mq_info::in, import_status::in,
@@ -957,29 +1121,31 @@
:- pred mq_info_set_error_context(mq_info::in, error_context::in,
mq_info::out) is det.
-mq_info_set_types(mq_info(_, B,C,D,E,F,G,H,I,J,K), Types,
- mq_info(Types, B,C,D,E,F,G,H,I,J,K)).
-mq_info_set_insts(mq_info(A,_,C,D,E,F,G,H,I,J,K), Insts,
- mq_info(A, Insts, C,D,E,F,G,H,I,J,K)).
-mq_info_set_modes(mq_info(A,B,_,D,E,F,G,H,I,J,K), Modes,
- mq_info(A,B, Modes, D,E,F,G,H,I,J,K)).
-mq_info_set_interface_modules(mq_info(A,B,C,_,E,F,G,H,I,J,K), Modules,
- mq_info(A,B,C, Modules, E,F,G,H,I,J,K)).
-mq_info_set_import_status(mq_info(A,B,C,D,_,F,G,H,I,J,K), Status,
- mq_info(A,B,C,D, Status, F,G,H,I,J,K)).
-mq_info_set_type_error_flag(mq_info(A,B,C,D,E,F, _, H,I,J,K),
- mq_info(A,B,C,D,E,F, yes, H,I,J,K)).
-mq_info_set_mode_error_flag(mq_info(A,B,C,D,E,F,G,_,I,J,K),
- mq_info(A,B,C,D,E,F,G, yes, I,J,K)).
-mq_info_set_error_context(mq_info(A,B,C,D,E,F,G,H,I,_,K), Context,
- mq_info(A,B,C,D,E,F,G,H,I, Context,K)).
-mq_info_set_need_qual_flag(mq_info(A,B,C,D,E,F,G,H,I,J,_), Flag,
- mq_info(A,B,C,D,E,F,G,H,I,J, Flag)).
+mq_info_set_types(mq_info(_, B,C,D,E,F,G,H,I,J,K,L), Types,
+ mq_info(Types, B,C,D,E,F,G,H,I,J,K,L)).
+mq_info_set_insts(mq_info(A,_,C,D,E,F,G,H,I,J,K,L), Insts,
+ mq_info(A, Insts, C,D,E,F,G,H,I,J,K,L)).
+mq_info_set_modes(mq_info(A,B,_,D,E,F,G,H,I,J,K,L), Modes,
+ mq_info(A,B, Modes, D,E,F,G,H,I,J,K,L)).
+mq_info_set_classes(mq_info(A,B,C,_,E,F,G,H,I,J,K,L), Classes,
+ mq_info(A,B, C, Classes,E,F,G,H,I,J,K,L)).
+mq_info_set_interface_modules(mq_info(A,B,C,D,_,F,G,H,I,J,K,L), Modules,
+ mq_info(A,B,C,D, Modules, F,G,H,I,J,K,L)).
+mq_info_set_import_status(mq_info(A,B,C,D,E,_,G,H,I,J,K,L), Status,
+ mq_info(A,B,C,D,E, Status, G,H,I,J,K,L)).
+mq_info_set_type_error_flag(mq_info(A,B,C,D,E,F,G, _, I,J,K,L),
+ mq_info(A,B,C,D,E,F,G, yes, I,J,K,L)).
+mq_info_set_mode_error_flag(mq_info(A,B,C,D,E,F,G,H,_,J,K,L),
+ mq_info(A,B,C,D,E,F,G,H, yes, J,K,L)).
+mq_info_set_error_context(mq_info(A,B,C,D,E,F,G,H,I,J,_,L), Context,
+ mq_info(A,B,C,D,E,F,G,H,I,J, Context,L)).
+mq_info_set_need_qual_flag(mq_info(A,B,C,D,E,F,G,H,I,J,K,_), Flag,
+ mq_info(A,B,C,D,E,F,G,H,I,J,K, Flag)).
:- pred mq_info_incr_errors(mq_info::in, mq_info::out) is det.
-mq_info_incr_errors(mq_info(A,B,C,D,E, NumErrors0, G,H,I,J,K),
- mq_info(A,B,C,D,E, NumErrors, G,H,I,J,K)) :-
+mq_info_incr_errors(mq_info(A,B,C,D,E,F, NumErrors0, H,I,J,K,L),
+ mq_info(A,B,C,D,E,F, NumErrors,H,I,J,K,L)) :-
NumErrors is NumErrors0 + 1.
:- pred mq_info_set_error_flag(mq_info::in, id_type::in, mq_info::out) is det.
@@ -990,6 +1156,8 @@
mq_info_set_mode_error_flag(Info0, Info).
mq_info_set_error_flag(Info0, inst_id, Info) :-
mq_info_set_mode_error_flag(Info0, Info).
+mq_info_set_error_flag(Info0, class_id, Info) :-
+ mq_info_set_type_error_flag(Info0, Info).
% If the current item is in the interface, remove its module
% name from the list of modules not used in the interface.
@@ -1032,6 +1200,7 @@
:- type type_id_set == id_set.
:- type mode_id_set == id_set.
:- type inst_id_set == id_set.
+:- type class_id_set == id_set.
:- pred id_set_init(id_set::out) is det.
Index: compiler/modules.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modules.m,v
retrieving revision 1.42
diff -u -r1.42 modules.m
--- modules.m 1997/10/16 04:59:11 1.42
+++ modules.m 1997/10/20 07:16:35
@@ -8,13 +8,13 @@
% main author: fjh
% This module contains all the code for handling module imports and exports,
-% for computing module dependencies, and for generate makefile fragments to
+% for computing module dependencies, and for generating makefile fragments to
% record those dependencies.
%
%
% The interface system works as follows:
%
-% 1. a .int3 file is written, which contains all the types, insts
+% 1. a .int3 file is written, which contains all the types, typeclasses, insts
% and modes defined in the interface. Equivalence types, insts and
% modes are written in full, others are written in abstract form.
% These are module qualified as far as possible given the information
@@ -1561,7 +1561,7 @@
% Given a module interface (well, a list of items), extract the
% short interface part of that module, i.e. the exported
- % type/inst/mode declarations, but not the exported pred or
+ % type/typeclass/inst/mode declarations, but not the exported pred or
% constructor declarations. If the module interface imports
% other modules, then the short interface only needs to include
% those import_module declarations only if the short interface
@@ -1625,6 +1625,7 @@
include_in_short_interface(inst_defn(_, _, _)).
include_in_short_interface(mode_defn(_, _, _)).
include_in_short_interface(module_defn(_, _)).
+include_in_short_interface(typeclass(_, _, _, _, _)).
:- pred make_abstract_type_defn(item, item).
:- mode make_abstract_type_defn(in, out) is semidet.
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/opt_debug.m,v
retrieving revision 1.74
diff -u -r1.74 opt_debug.m
--- opt_debug.m 1997/11/08 13:11:38 1.74
+++ opt_debug.m 1997/11/17 06:23:10
@@ -687,6 +687,8 @@
string__append("common", N_str, Str).
opt_debug__dump_data_name(base_type(BaseData, TypeName, TypeArity), Str) :-
llds_out__make_base_type_name(BaseData, TypeName, TypeArity, Str).
+opt_debug__dump_data_name(base_typeclass_info(ClassId, InstanceNum), Str) :-
+ llds_out__make_base_typeclass_info_name(ClassId, InstanceNum, Str).
opt_debug__dump_data_name(stack_layout(Label), Str) :-
opt_debug__dump_label(Label, LabelStr),
string__append_list(["stack_layout(", LabelStr, ")"], Str).
@@ -738,6 +740,9 @@
opt_debug__dump_code_addr(do_det_closure, "do_det_closure").
opt_debug__dump_code_addr(do_semidet_closure, "do_semidet_closure").
opt_debug__dump_code_addr(do_nondet_closure, "do_nondet_closure").
+opt_debug__dump_code_addr(do_det_class_method, "do_det_class_method").
+opt_debug__dump_code_addr(do_semidet_class_method, "do_semidet_class_method").
+opt_debug__dump_code_addr(do_nondet_class_method, "do_nondet_class_method").
opt_debug__dump_code_addr(do_not_reached, "do_not_reached").
opt_debug__dump_code_addrs([], "").
Index: compiler/opt_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/opt_util.m,v
retrieving revision 1.84
diff -u -r1.84 opt_util.m
--- opt_util.m 1997/08/25 17:48:34 1.84
+++ opt_util.m 1997/09/08 04:13:07
@@ -1199,6 +1199,9 @@
opt_util__livevals_addr(do_det_closure, yes).
opt_util__livevals_addr(do_semidet_closure, yes).
opt_util__livevals_addr(do_nondet_closure, yes).
+opt_util__livevals_addr(do_det_class_method, yes).
+opt_util__livevals_addr(do_semidet_class_method, yes).
+opt_util__livevals_addr(do_nondet_class_method, yes).
opt_util__livevals_addr(do_not_reached, no).
opt_util__count_temps_instr_list([], R, R, F, F).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.118
diff -u -r1.118 polymorphism.m
--- polymorphism.m 1997/10/14 09:27:53 1.118
+++ polymorphism.m 1997/11/20 04:49:20
@@ -8,9 +8,10 @@
% main author: fjh
% This module is a pass over the HLDS.
-% It does a syntactic transformation to implement polymorphism
-% using higher-order predicates, and also invokes `lambda__transform_lambda'
-% to handle lambda expressions by creating new predicates for them.
+% It does a syntactic transformation to implement polymorphism, including
+% typeclasses, using higher-order predicates, and also invokes
+% `lambda__transform_lambda' to handle lambda expressions by creating new
+% predicates for them.
%
%-----------------------------------------------------------------------------%
%
@@ -40,7 +41,7 @@
% word 3 <compare/3 predicate for type>
% word 4 <base_type_layout for type>
% word 5 <base_type_functors for type>
-% word 6 <string name of type>
+% word 6 <string name of type constructor>
% e.g. "int" for `int', "list" for `list(T)',
% "map" for `map(K,V)'
% word 7 <string name of module>
@@ -150,6 +151,126 @@
% single shared base_type_info.
%
%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%
+% Tranformation of code using typeclasses:
+%
+% Every predicate which has a typeclass constraint is given an extra
+% argument for every constraint in the predicate's type declaration.
+% The argument is the "dictionary", or "typeclass_info" for the typeclass.
+% The dictionary contains pointers to each of the class methods
+%
+%-----------------------------------------------------------------------------%
+%
+% Representation of a typeclass_info:
+% The typeclass_info is represented in two parts (the typeclass_info
+% itself, and a base_typeclass_info), in a similar fashion to the
+% type_info being represented in two parts (the type_info and the
+% base_type_info).
+%
+% The base_type_info contains:
+% * arity of the instance declaration (ie. the number of
+% constraints on the decl).
+% * pointer to method #1
+% ...
+% * pointer to method #n
+%
+% The type_info contains:
+% * a pointer to the base typeclass info
+% * typeclass info #1 for constraint on instance decl
+% * ...
+% * typeclass info #n for constraint on instance decl
+% * typeclass info for superclass #1
+% ...
+% * typeclass info for superclass #n
+% * type info #1
+% * ...
+% * type info #n
+%
+% The base_type_info is produced statically, and there is one for each instance
+% declaration. For each constraint on the instance declaration, the
+% corresponding typeclass info is stored in the second part.
+%
+% eg. for the following program:
+%
+% :- typeclass foo(T) where [...].
+% :- instance foo(int) where [...].
+% :- instance foo(list(T)) <= foo(T) where [...].
+%
+% The typeclass_info for foo(int) is:
+% The base_type_info:
+% * 0 (arity of the instance declaration)
+% * pointer to method #1
+% ...
+% * pointer to method #n
+%
+% The type_info:
+% * a pointer to the base typeclass info
+% * type info for int
+%
+% The typeclass_info for foo(list(T)) is:
+% The base_type_info:
+% * 1 (arity of the instance declaration)
+% * pointer to method #1
+% ...
+% * pointer to method #n
+%
+% The type_info contains:
+% * a pointer to the base typeclass info
+% * typeclass info for foo(T)
+% * type info for list(T)
+%
+% Where the "T" for the list is known, the whole typeclass_info will be static
+% data. When we do not know until runtime, the typeclass_info is constructed
+% dynamically.
+%
+%-----------------------------------------------------------------------------%
+%
+% Example of transformation:
+%
+% Take the following code as an example (assuming the declarations above),
+% ignoring the requirement for super-homogeneous form for clarity:
+%
+% :- pred p(T1) <= foo(T1).
+% :- pred q(T2) <= foo(T2).
+% :- pred r(T3, T4) <= foo(T3).
+%
+% p(X) :- q([X]), r(0, X).
+%
+% We add an extra argument for each typeclass constraint, and one argument for
+% each unconstrained type variable.
+%
+% :- pred p(typeclass_info(foo(T1)), T1).
+% :- pred q(typeclass_info(foo(T2)), T2).
+% :- pred r(typeclass_info(foo(T3)), type_info(T4), T3, T4).
+%
+% We transform the body of p to this:
+%
+% p(TypeClassInfoT1, X) :-
+% BaseTypeClassInfoT2 = base_typeclass_info(
+% 1,
+% ...
+% ... (The methods for the class from the list instance)
+% ...
+% ),
+% TypeClassInfoT2 = typeclass_info(
+% BaseTypeInfoT2,
+% TypeClassInfoT1,
+% <type_info for list(T1)>,
+% q(TypeClassInfoT2, [X]),
+% BaseTypeClassInfoT3 = baseclass_type_info(
+% 0,
+% ...
+% ... (The methods for the class from the int instance)
+% ...
+% ),
+% TypeClassInfoT3 = typeclass_info(
+% BaseTypeInfoT3,
+% <type_info for int>),
+% r(TypeClassInfoT1, TypeInfoT3, 0, X).
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- module polymorphism.
:- interface.
@@ -166,10 +287,10 @@
:- import_module hlds_pred, hlds_goal, hlds_data, llds, (lambda), globals.
:- import_module prog_data, type_util, mode_util, quantification, instmap.
:- import_module code_util, unify_proc, special_pred, prog_util, make_hlds.
-:- import_module (inst), hlds_out.
+:- import_module std_util, (inst), hlds_out, base_typeclass_info.
:- import_module bool, int, string, list, set, map.
-:- import_module term, varset, std_util, require.
+:- import_module term, varset, std_util, require, assoc_list.
%-----------------------------------------------------------------------------%
@@ -187,7 +308,8 @@
polymorphism__process_preds(PredIds0, ModuleInfo0, ModuleInfo1),
module_info_preds(ModuleInfo1, Preds1),
map__keys(Preds1, PredIds1),
- polymorphism__fixup_preds(PredIds1, ModuleInfo1, ModuleInfo).
+ polymorphism__fixup_preds(PredIds1, ModuleInfo1, ModuleInfo2),
+ polymorphism__expand_class_method_bodies(ModuleInfo2, ModuleInfo).
:- pred polymorphism__process_preds(list(pred_id), module_info, module_info).
:- mode polymorphism__process_preds(in, in, out) is det.
@@ -284,9 +406,32 @@
varset, % from the proc_info
map(var, type), % from the proc_info
tvarset, % from the proc_info
- map(tvar, var), % specifies the type_info var
+ map(tvar, type_info_locn),
+ % specifies the location of
+ % the type_info var
% for each of the pred's type
% parameters
+
+ map(class_constraint, var),
+ % specifies the location of
+ % the typeclass_info var
+ % for each of the pred's class
+ % constraints
+ map(class_constraint, constraint_proof),
+ % specifies why each constraint
+ % that was eliminated from the
+ % pred was able to be eliminated
+ % (this allows us to efficiently
+ % construct the dictionary)
+
+ % Note that the two maps above
+ % are separate since the second
+ % is the information calculated
+ % by typecheck.m, while the
+ % first is the information
+ % calculated here in
+ % polymorphism.m
+
string, % pred name
module_info
).
@@ -300,34 +445,76 @@
% grab the appropriate fields from the pred_info and proc_info
pred_info_arg_types(PredInfo0, ArgTypeVarSet, ArgTypes),
pred_info_typevarset(PredInfo0, TypeVarSet0),
+ pred_info_get_class_context(PredInfo0, ClassContext),
+ pred_info_get_constraint_proofs(PredInfo0, Proofs),
pred_info_name(PredInfo0, PredName),
proc_info_headvars(ProcInfo0, HeadVars0),
proc_info_variables(ProcInfo0, VarSet0),
proc_info_vartypes(ProcInfo0, VarTypes0),
proc_info_goal(ProcInfo0, Goal0),
proc_info_argmodes(ProcInfo0, ArgModes0),
- % insert extra head variables to hold the address of the
- % equality predicate for each polymorphic type in the predicate's
- % type declaration
+
+
+ % Insert extra head variables to hold the address of the
+ % type_infos and typeclass_infos.
+ % We insert one variable for each unconstrained type variable
+ % (for the type_info) and one variable for each constraint (for
+ % the typeclass_info).
term__vars_list(ArgTypes, HeadTypeVars0),
- list__remove_dups(HeadTypeVars0, HeadTypeVars), % remove duplicates
- polymorphism__make_head_vars(HeadTypeVars, ArgTypeVarSet,
- VarSet0, VarTypes0, ExtraHeadVars, VarSet1, VarTypes1),
- list__append(ExtraHeadVars, HeadVars0, HeadVars),
- list__length(ExtraHeadVars, NumExtraVars),
+ % Make a fresh variable for each class constraint, returning
+ % a list of variables that appear in the constraints, along
+ % with the location of the type infos for them.
+ polymorphism__make_typeclass_info_head_vars(ClassContext, ModuleInfo0,
+ VarSet0, VarTypes0, ExtraHeadTypeclassInfoVars,
+ TypeClassInfoMap, ConstrainedTVars,
+ VarSet1, VarTypes1),
+
+ list__delete_elems(HeadTypeVars0, ConstrainedTVars,
+ UnconstrainedTVars0),
+ list__remove_dups(UnconstrainedTVars0, UnconstrainedTVars),
+
+ polymorphism__make_head_vars(UnconstrainedTVars, ArgTypeVarSet,
+ VarSet1, VarTypes1, ExtraHeadTypeInfoVars, VarSet2, VarTypes2),
+
+ % First the type_infos, then the typeclass_infos,
+ % but we have to do it in reverse because we're appending...
+ list__append(ExtraHeadTypeclassInfoVars, HeadVars0, HeadVars1),
+ list__append(ExtraHeadTypeInfoVars, HeadVars1, HeadVars),
+
+ % Work out the total number of new vars
+ list__length(ExtraHeadTypeInfoVars, NumExtraVars0),
+ list__length(ExtraHeadTypeclassInfoVars, NumExtraVars1),
+ NumExtraVars is NumExtraVars1 + NumExtraVars0,
+
list__duplicate(NumExtraVars, user_defined_mode(
qualified("mercury_builtin", "in"), []), ExtraModes),
list__append(ExtraModes, ArgModes0, ArgModes),
+ % Make a map of the locations of the unconstrained typeinfos
+ AddLocn = lambda([TVarAndVar::in, TIM0::in, TIM::out] is det,
+ (
+ TVarAndVar = TVar - TheVar,
+ map__det_insert(TIM0, TVar, type_info(TheVar), TIM)
+ )),
+ assoc_list__from_corresponding_lists(UnconstrainedTVars,
+ ExtraHeadTypeInfoVars, TVarsAndVars),
+ list__foldl(AddLocn, TVarsAndVars, TypeClassInfoMap, TypeInfoMap1),
+
+
+ % Make a map of the locations of the typeclass_infos
+ map__from_corresponding_lists(ClassContext, ExtraHeadTypeclassInfoVars,
+ TypeclassInfoLocations0),
+
+ Info0 = poly_info(VarSet2, VarTypes2, TypeVarSet0,
+ TypeInfoMap1, TypeclassInfoLocations0,
+ Proofs, PredName, ModuleInfo0),
+
% process any polymorphic calls inside the goal
- map__from_corresponding_lists(HeadTypeVars, ExtraHeadVars,
- TypeInfoMap0),
- Info0 = poly_info(VarSet1, VarTypes1, TypeVarSet0,
- TypeInfoMap0, PredName, ModuleInfo0),
polymorphism__process_goal(Goal0, Goal1, Info0, Info1),
polymorphism__fixup_quantification(Goal1, Goal, Info1, Info),
- Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap, _PredName,
- ModuleInfo),
+ Info = poly_info(VarSet, VarTypes, TypeVarSet,
+ TypeInfoMap, TypeclassInfoLocations,
+ _Proofs, _PredName, ModuleInfo),
% set the new values of the fields in proc_info and pred_info
proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1),
@@ -335,7 +522,9 @@
proc_info_set_varset(ProcInfo2, VarSet, ProcInfo3),
proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo4),
proc_info_set_argmodes(ProcInfo4, ArgModes, ProcInfo5),
- proc_info_set_typeinfo_varmap(ProcInfo5, TypeInfoMap, ProcInfo),
+ proc_info_set_typeinfo_varmap(ProcInfo5, TypeInfoMap, ProcInfo6),
+ proc_info_set_typeclass_info_varmap(ProcInfo6, TypeclassInfoLocations,
+ ProcInfo),
pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
:- pred polymorphism__process_goal(hlds_goal, hlds_goal,
@@ -357,6 +546,11 @@
GoalInfo, higher_order_call(A, B, C, D, E, F) - GoalInfo)
--> [].
+ % The same goes for class method calls
+polymorphism__process_goal_expr(class_method_call(A, B, C, D, E, F),
+ GoalInfo, class_method_call(A, B, C, D, E, F) - GoalInfo)
+ --> [].
+
polymorphism__process_goal_expr(call(PredId0, ProcId0, ArgVars0,
Builtin, Context, Name0), GoalInfo, Goal) -->
% Check for a call to a special predicate like compare/3
@@ -368,7 +562,7 @@
{ list__length(ArgVars0, Arity) },
{ special_pred_name_arity(SpecialPredId, PredName0,
MangledPredName, Arity) },
- =(poly_info(_, VarTypes, _, _TypeInfoMap, _PN, ModuleInfo)),
+ =(poly_info(_, VarTypes, _, _, _, _, _, ModuleInfo)),
{ special_pred_get_type(MangledPredName, ArgVars0, MainVar) },
{ map__lookup(VarTypes, MainVar, Type) },
{ Type \= term__variable(_) },
@@ -404,7 +598,7 @@
{ Unification = complicated_unify(UniMode, CanFail) },
{ Y = var(YVar) }
->
- =(poly_info(_, VarTypes, _, TypeInfoMap, _PName, ModuleInfo)),
+ =(poly_info(_, VarTypes, _, TypeInfoMap, _, _, _, ModuleInfo)),
{ map__lookup(VarTypes, XVar, Type) },
( { Type = term__variable(TypeVar) } ->
% Convert polymorphic unifications into calls to
@@ -428,14 +622,48 @@
% polymorphically typed variables in partially
% instantiated mode") if it isn't
{ hlds_pred__in_in_unification_proc_id(ProcId) },
- { map__lookup(TypeInfoMap, TypeVar, TypeInfoVar) },
+ { map__lookup(TypeInfoMap, TypeVar, TypeInfoLocn) },
{ SymName = unqualified("unify") },
- { ArgVars = [TypeInfoVar, XVar, YVar] },
{ code_util__builtin_state(ModuleInfo, PredId, ProcId,
BuiltinState) },
{ CallContext = call_unify_context(XVar, Y, Context) },
- { Goal = call(PredId, ProcId, ArgVars, BuiltinState,
- yes(CallContext), SymName) - GoalInfo }
+ (
+ % If the typeinfo is available in a
+ % variable, just use it
+ { TypeInfoLocn = type_info(TypeInfoVar) },
+ { ArgVars = [TypeInfoVar, XVar, YVar] },
+ { Goal = call(PredId, ProcId, ArgVars,
+ BuiltinState, yes(CallContext), SymName)
+ - GoalInfo }
+ ;
+ % If the typeinfo is in a
+ % typeclass_info, first extract it,
+ % then use it
+ { TypeInfoLocn =
+ typeclass_info(TypeClassInfoVar,
+ Index) },
+ extract_type_info(Type, TypeVar,
+ TypeClassInfoVar, Index,
+ Goals, TypeInfoVar),
+
+ { ArgVars = [TypeInfoVar, XVar, YVar] },
+ { Call = call(PredId, ProcId, ArgVars,
+ BuiltinState, yes(CallContext), SymName)
+ - GoalInfo },
+
+ % The TypeClassInfoVar is also nonlocal
+ % to this conj, since it is used to
+ % extract the type_info
+ %
+ % XXX Do I need to do this?
+ { goal_info_get_nonlocals(GoalInfo,
+ NonLocals0) },
+ { set__insert(NonLocals0, TypeClassInfoVar,
+ NonLocals) },
+ { goal_info_set_nonlocals(GoalInfo, NonLocals,
+ NewGoalInfo) },
+ { Goal = conj([Call|Goals]) - NewGoalInfo }
+ )
; { type_is_higher_order(Type, _, _) } ->
{ SymName = unqualified("builtin_unify_pred") },
@@ -537,7 +765,7 @@
% so that the c_code can refer to the type_info variable
% for type T as `TypeInfo_for_T'.
%
- =(poly_info(_, _, _, _, _, ModuleInfo)),
+ =(poly_info(_, _, _, _, _, _, _, ModuleInfo)),
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
{ pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes) },
{ term__vars_list(PredArgTypes, PredTypeVars0) },
@@ -612,14 +840,17 @@
polymorphism__process_call(PredId, _ProcId, ArgVars0, ArgVars,
ExtraVars, ExtraGoals, Info0, Info) :-
- Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0,
- TypeInfoMap0, PredName, ModuleInfo),
+
+ Info0 = poly_info(A, VarTypes, TypeVarSet0, D, E, F, G, ModuleInfo),
+
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes0),
+ pred_info_get_class_context(PredInfo, PredClassContext0),
% rename apart
% (this merge might be a performance bottleneck?)
- varset__merge(TypeVarSet0, PredTypeVarSet, PredArgTypes0,
- TypeVarSet, PredArgTypes),
+ varset__merge_subst(TypeVarSet0, PredTypeVarSet, TypeVarSet, Subst),
+ term__apply_substitution_to_list(PredArgTypes0, Subst,
+ PredArgTypes),
term__vars_list(PredArgTypes, PredTypeVars0),
( PredTypeVars0 = [] ->
% optimize for common case of non-polymorphic call
@@ -628,24 +859,47 @@
ExtraVars = [],
Info = Info0
;
- list__remove_dups(PredTypeVars0, PredTypeVars),
- map__apply_to_list(ArgVars0, VarTypes0, ActualArgTypes),
+ list__remove_dups(PredTypeVars0, PredTypeVars1),
+ map__apply_to_list(ArgVars0, VarTypes, ActualArgTypes),
( type_list_subsumes(PredArgTypes, ActualArgTypes,
TypeSubst1) ->
TypeSubst = TypeSubst1
;
error("polymorphism__process_goal_expr: type unification failed")
),
+
+
+ apply_subst_to_constraints(Subst, PredClassContext0,
+ PredClassContext),
+
+ Info1 = poly_info(A, VarTypes, TypeVarSet, D, E, F, G,
+ ModuleInfo),
+
+ % Make the typeclass_infos for the call, and return
+ % a list of which variables were constrained by the
+ % context
+ polymorphism__make_typeclass_info_vars(PredClassContext,
+ Subst, TypeSubst, ExtraTypeClassVars,
+ ExtraTypeClassGoals, ConstrainedVars, Info1, Info2),
+
+ % No need to make typeinfos for the constrained vars
+ list__delete_elems(PredTypeVars1, ConstrainedVars,
+ PredTypeVars),
+
term__var_list_to_term_list(PredTypeVars, PredTypes0),
term__apply_rec_substitution_to_list(PredTypes0, TypeSubst,
PredTypes),
- polymorphism__make_vars(PredTypes, ModuleInfo, TypeInfoMap0,
- VarSet0, VarTypes0,
- ExtraVars, TypeInfoMap, ExtraGoals, VarSet,
- VarTypes),
- list__append(ExtraVars, ArgVars0, ArgVars),
- Info = poly_info(VarSet, VarTypes, TypeVarSet,
- TypeInfoMap, PredName, ModuleInfo)
+
+ polymorphism__make_type_info_vars(PredTypes,
+ ExtraTypeInfoVars, ExtraTypeInfoGoals,
+ Info2, Info),
+ list__append(ExtraTypeClassVars, ArgVars0, ArgVars1),
+ list__append(ExtraTypeInfoVars, ArgVars1, ArgVars),
+ list__append(ExtraTypeClassGoals, ExtraTypeInfoGoals,
+ ExtraGoals),
+ list__append(ExtraTypeClassVars, ExtraTypeInfoVars,
+ ExtraVars)
+
).
:- pred polymorphism__fixup_quantification(hlds_goal, hlds_goal,
@@ -661,31 +915,43 @@
polymorphism__fixup_quantification(Goal0, Goal, Info0, Info) :-
Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeVarMap,
- PredName, ModuleInfo),
+ TypeClassVarMap, Proofs, PredName, ModuleInfo),
( map__is_empty(TypeVarMap) ->
Info = Info0,
Goal = Goal0
;
%
- % A type-info variable may be non-local to a goal if any of
+ % A type-info variable may be non-local to a goal if any of
% the ordinary non-local variables for that goal are
% polymorphically typed with a type that depends on that
% type-info variable.
%
+ % In addition, a typeclass-info is non-local to a goal if any
+ % of the non-local variables for that goal are polymorphically
+ % typed and are constrained by the typeclass constraints for
+ % that typeclass-info variable
+ %
Goal0 = _ - GoalInfo0,
goal_info_get_nonlocals(GoalInfo0, NonLocals),
set__to_sorted_list(NonLocals, NonLocalsList),
map__apply_to_list(NonLocalsList, VarTypes0, NonLocalsTypes),
term__vars_list(NonLocalsTypes, NonLocalTypeVars),
- solutions_set(lambda([TypeInfoVar::out] is nondet, (
- list__member(Var, NonLocalTypeVars),
- map__search(TypeVarMap, Var, TypeInfoVar)
+ % Find all the type-infos and typeclass-infos that are
+ % non-local
+ solutions_set(lambda([Var::out] is nondet, (
+ list__member(TheVar, NonLocalTypeVars),
+ map__search(TypeVarMap, TheVar, Location),
+ (
+ Location = type_info(Var)
+ ;
+ Location = typeclass_info(Var, _)
+ )
)), NewOutsideVars),
set__union(NewOutsideVars, NonLocals, OutsideVars),
implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
OutsideVars, Goal, VarSet, VarTypes, _Warnings),
Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarMap,
- PredName, ModuleInfo)
+ TypeClassVarMap, Proofs, PredName, ModuleInfo)
).
:- pred polymorphism__process_lambda(pred_or_func, list(var),
@@ -697,50 +963,469 @@
polymorphism__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals,
LambdaGoal, Unification0, Functor, Unification,
PolyInfo0, PolyInfo) :-
- PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap, PredName,
- ModuleInfo0),
+ PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
+ TCVarMap, Proofs, PredName, ModuleInfo0),
+
+ % XXX This is wrong. What is the class context really?
+ Constraints = [],
+
lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
OrigNonLocals, LambdaGoal, Unification0, VarSet, VarTypes,
- TVarSet, TVarMap, ModuleInfo0, Functor,
+ Constraints, TVarSet, TVarMap, TCVarMap, ModuleInfo0, Functor,
Unification, ModuleInfo),
- PolyInfo = poly_info(VarSet, VarTypes, TVarSet, TVarMap, PredName,
- ModuleInfo).
+ PolyInfo = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
+ TCVarMap, Proofs, PredName, ModuleInfo).
+
+%---------------------------------------------------------------------------%
+
+% Given a list of constraints, create a list of variables to hold the
+% typeclass_info for those constraints, and create a list of goals to
+% initialize those typeclass_info variables to the appropriate
+% typeclass_info structures for the constraints.
+
+:- pred polymorphism__make_typeclass_info_vars(list(class_constraint),
+ substitution, tsubst, list(var), list(hlds_goal), list(var),
+ poly_info, poly_info).
+:- mode polymorphism__make_typeclass_info_vars(in, in, in, out, out, out,
+ in, out) is det.
+
+polymorphism__make_typeclass_info_vars(PredClassContext, Subst, TypeSubst,
+ ExtraVars, ExtraGoals, ConstrainedVars, Info0, Info) :-
+
+ % initialise the accumulators
+ ExtraVars0 = [],
+ ExtraGoals0 = [],
+ ConstrainedVars0 = [],
+
+ % do the work
+ polymorphism__make_typeclass_info_vars_2(PredClassContext,
+ Subst, TypeSubst,
+ ExtraVars0, ExtraVars1,
+ ExtraGoals0, ExtraGoals1,
+ ConstrainedVars0, ConstrainedVars,
+ Info0, Info),
+
+ % We build up the vars and goals in reverse order
+ list__reverse(ExtraVars1, ExtraVars),
+ list__reverse(ExtraGoals1, ExtraGoals).
+
+% Accumulator version of the above.
+:- pred polymorphism__make_typeclass_info_vars_2(list(class_constraint),
+ substitution, tsubst,
+ list(var), list(var),
+ list(hlds_goal), list(hlds_goal),
+ list(var), list(var),
+ poly_info, poly_info).
+:- mode polymorphism__make_typeclass_info_vars_2(in, in, in, in, out, in, out,
+ in, out, in, out) is det.
+
+polymorphism__make_typeclass_info_vars_2([], _Subst, _TypeSubst,
+ ExtraVars, ExtraVars,
+ ExtraGoals, ExtraGoals,
+ ConstrainedVars, ConstrainedVars,
+ Info, Info).
+polymorphism__make_typeclass_info_vars_2([C|Cs], Subst, TypeSubst,
+ ExtraVars0, ExtraVars,
+ ExtraGoals0, ExtraGoals,
+ ConstrainedVars0, ConstrainedVars,
+ Info0, Info) :-
+ polymorphism__make_typeclass_info_var(C, Subst, TypeSubst,
+ ExtraGoals0, ExtraGoals1,
+ ConstrainedVars0, ConstrainedVars1, Info0, Info1,
+ ExtraVar),
+ polymorphism__make_typeclass_info_vars_2(Cs, Subst, TypeSubst,
+ [ExtraVar|ExtraVars0], ExtraVars,
+ ExtraGoals1, ExtraGoals,
+ ConstrainedVars1, ConstrainedVars,
+ Info1, Info).
+
+:- pred polymorphism__make_typeclass_info_var(class_constraint,
+ substitution, tsubst,
+ list(hlds_goal), list(hlds_goal),
+ list(var), list(var),
+ poly_info, poly_info,
+ var).
+:- mode polymorphism__make_typeclass_info_var(in, in, in, in, out, in, out,
+ in, out, out) is det.
+
+polymorphism__make_typeclass_info_var(Constraint, Subst, TypeSubst,
+ ExtraGoals0, ExtraGoals,
+ ConstrainedVars0, ConstrainedVars,
+ Info0, Info, Var) :-
+ Constraint = constraint(ClassName, NewConstrainedTypes),
+ list__length(NewConstrainedTypes, ClassArity),
+ ClassId = class_id(ClassName, ClassArity),
+ term__vars_list(NewConstrainedTypes, NewConstrainedVars),
+ list__append(NewConstrainedVars, ConstrainedVars0, ConstrainedVars),
+ term__apply_rec_substitution_to_list(NewConstrainedTypes, TypeSubst,
+ ConstrainedTypes),
+ NewC = constraint(ClassName, ConstrainedTypes),
+
+ Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0, TypeInfoMap0,
+ TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
+
+ (
+ map__search(TypeClassInfoMap0, NewC, Location)
+ ->
+ % We already have a typeclass_info for this constraint
+ ExtraGoals = ExtraGoals0,
+ Var = Location,
+ Info = Info0
+ ;
+ % We don't have the typeclass_info as a parameter to
+ % the pred, so we must be able to create it from
+ % somewhere else
+
+ % Work out how to make it
+ map__lookup(Proofs, NewC, Proof),
+ (
+ % We have to construct the typeclass_info
+ % using an instance declaration
+ Proof = apply_instance(InstanceDefn, InstanceNum),
+
+ % The subst has already been applied to these
+ % constraints in typecheck.m
+ InstanceDefn = hlds_instance_defn(_,
+ InstanceConstraints, _, _, _, _, _),
+
+ % Make the type_infos for the types that are
+ % constrained by this. These are packaged in
+ % the typeclass_info
+ polymorphism__make_type_info_vars(ConstrainedTypes,
+ InstanceExtraTypeInfoVars, TypeInfoGoals,
+ Info0, Info1),
+
+ % Make the typeclass_infos for the constraints
+ % from the context of the instance decl.
+ polymorphism__make_typeclass_info_vars_2(
+ InstanceConstraints,
+ Subst, TypeSubst,
+ [], InstanceExtraTypeClassInfoVars,
+ ExtraGoals0, ExtraGoals1,
+ [], _, Info1, Info2),
+
+ polymorphism__construct_typeclass_info(
+ InstanceExtraTypeInfoVars,
+ InstanceExtraTypeClassInfoVars,
+ ClassId, InstanceNum, Var, NewGoals,
+ Info2, Info),
+
+ % Oh, yuck. The type_info goals have already
+ % been reversed, so lets reverse them back.
+ list__reverse(TypeInfoGoals, RevTypeInfoGoals),
+
+ list__append(ExtraGoals1, RevTypeInfoGoals,
+ ExtraGoals2),
+ list__append(NewGoals, ExtraGoals2, ExtraGoals)
+ ;
+ % We have to extract the typeclass_info from
+ % another one
+ Proof = superclass(SubClassConstraint0),
+
+ % 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),
+
+ % Then work out where to extract it from
+ SubClassConstraint0 =
+ constraint(SubClassName, SubClassTypes0),
+ term__apply_substitution_to_list(SubClassTypes0, Subst,
+ SubClassTypes),
+ SubClassConstraint =
+ constraint(SubClassName, SubClassTypes),
+ list__length(SubClassTypes, SubClassArity),
+ SubClassId = class_id(SubClassName, SubClassArity),
+
+ Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet0,
+ TypeInfoMap0, TypeClassInfoMap0, Proofs,
+ PredName, ModuleInfo),
+
+ % Make the typeclass_info for the subclass
+ polymorphism__make_typeclass_info_var(
+ SubClassConstraint,
+ Subst, TypeSubst,
+ ExtraGoals0, ExtraGoals1,
+ [], _,
+ Info1, Info2,
+ SubClassVar),
+
+ % Look up the definition of the subclass
+ module_info_classes(ModuleInfo, ClassTable),
+ map__lookup(ClassTable, SubClassId, SubClassDefn),
+ SubClassDefn = hlds_class_defn(SuperClasses0,
+ SubClassVars, _, _),
+
+ % 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),
+ (
+ type_list_subsumes(SubClassVarTerms,
+ SubClassTypes, SubTypeSubst0)
+ ->
+ SubTypeSubst0 = SubTypeSubst
+ ;
+ error("polymorphism__make_typeclass_info_var")
+ ),
+ apply_rec_subst_to_constraints(SubTypeSubst,
+ SuperClasses0, SuperClasses),
+ (
+ list__nth_member_search(SuperClasses,
+ Constraint, SuperClassIndex0)
+ ->
+ SuperClassIndex0 = SuperClassIndex
+ ;
+ % We shouldn't have got this far if
+ % the constraints were not satifsied
+ error("polymorphism.m: constraint not in constraint list")
+ ),
+
+ Info2 = poly_info(VarSet2, VarTypes2, TypeVarSet2,
+ TypeInfoMap2, TypeClassInfoMap2, Proofs2,
+ PredName2, ModuleInfo2),
+
+ polymorphism__make_count_var(SuperClassIndex, VarSet2,
+ VarTypes2, IndexVar, IndexGoal, VarSet,
+ VarTypes),
+
+ Info = poly_info(VarSet, VarTypes, TypeVarSet2,
+ TypeInfoMap2, TypeClassInfoMap2, Proofs2,
+ PredName2, ModuleInfo2),
+
+ % We extract the superclass typeclass_info by
+ % inserting a call to
+ % superclass_from_typeclass_info in
+ % mercury_builtin.
+
+ % Make the goal for the call
+ varset__init(Empty),
+ term__context_init(EmptyContext),
+ ExtractSuperClass =
+ qualified("mercury_builtin",
+ "superclass_from_typeclass_info"),
+ TypeClassInfoTerm = term__functor(
+ term__atom("typeclass_info"), [],
+ EmptyContext),
+ IntTerm = term__functor(
+ term__atom("int"), [],
+ EmptyContext),
+ get_pred_id_and_proc_id(ExtractSuperClass, predicate,
+ Empty,
+ [TypeClassInfoTerm, IntTerm, TypeClassInfoTerm],
+ ModuleInfo, PredId, ProcId),
+ Call = call(PredId, ProcId,
+ [SubClassVar, IndexVar, Var],
+ not_builtin, no,
+ ExtractSuperClass
+ ),
+
+ % Make the goal info for the call
+ set__list_to_set([SubClassVar, IndexVar, Var],
+ NonLocals),
+ instmap_delta_from_assoc_list(
+ [Var - ground(shared, no)],
+ InstmapDelta),
+ goal_info_init(NonLocals, InstmapDelta, det, GoalInfo),
+
+ % Put them together
+ SuperClassGoal = Call - GoalInfo,
+
+ % Add it to the accumulator
+ ExtraGoals = [SuperClassGoal,IndexGoal|ExtraGoals1]
+ )
+ ).
+
+:- pred polymorphism__construct_typeclass_info(list(var), list(var), class_id,
+ int, var, list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__construct_typeclass_info(in, in, in, in, out, out,
+ in, out) is det.
+
+polymorphism__construct_typeclass_info(ArgTypeInfoVars, ArgTypeClassInfoVars,
+ ClassId, InstanceNum, NewVar, NewGoals, Info0, Info) :-
+
+ Info0 = poly_info(_, _, _, _, _, _, _, ModuleInfo),
+
+ module_info_instances(ModuleInfo, InstanceTable),
+ map__lookup(InstanceTable, ClassId, InstanceList),
+ list__index1_det(InstanceList, InstanceNum, InstanceDefn),
+ InstanceDefn = hlds_instance_defn(_, _, InstanceTypes, _, _, _,
+ SuperClassProofs),
+
+ module_info_classes(ModuleInfo, ClassTable),
+ map__lookup(ClassTable, ClassId, ClassDefn),
+
+ polymorphism__get_arg_superclass_vars(ClassDefn, InstanceTypes,
+ SuperClassProofs, ArgSuperClassVars, SuperClassGoals,
+ Info0, Info1),
+
+ Info1 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap, TCVarMap,
+ Proofs, PredName, _),
+
+ % lay out the argument variables as expected in the
+ % typeclass_info
+ list__append(ArgTypeClassInfoVars, ArgSuperClassVars, ArgVars0),
+ list__append(ArgVars0, ArgTypeInfoVars, ArgVars),
+
+ ClassId = class_id(ClassName, _Arity),
+
+ unqualify_name(ClassName, ClassNameString),
+ polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
+ ClassNameString, BaseVar, VarSet1, VarTypes1),
+
+ base_typeclass_info__make_instance_string(InstanceTypes,
+ InstanceString),
+
+ % XXX I don't think we actually need to carry this string
+ % around.
+ ModuleName = "some bogus string",
+ ConsId = base_typeclass_info_const(ModuleName, ClassId, InstanceString),
+ BaseTypeClassInfoTerm = functor(ConsId, []),
+
+ % create the construction unification to initialize the variable
+ BaseUnification = construct(BaseVar, ConsId, [], []),
+ BaseUnifyMode = (free -> ground(shared, no)) -
+ (ground(shared, no) -> ground(shared, no)),
+ BaseUnifyContext = unify_context(explicit, []),
+ % XXX the UnifyContext is wrong
+ BaseUnify = unify(BaseVar, BaseTypeClassInfoTerm, BaseUnifyMode,
+ BaseUnification, BaseUnifyContext),
+
+ % create a goal_info for the unification
+ set__list_to_set([BaseVar], NonLocals),
+ instmap_delta_from_assoc_list([BaseVar - ground(shared, no)],
+ InstmapDelta),
+ goal_info_init(NonLocals, InstmapDelta, det, BaseGoalInfo),
+
+ BaseGoal = BaseUnify - BaseGoalInfo,
+
+ % build a unification to add the argvars to the
+ % base_typeclass_info
+ NewConsId = cons(qualified("mercury_builtin", "typeclass_info"), 1),
+ NewArgVars = [BaseVar|ArgVars],
+ TypeClassInfoTerm = functor(NewConsId, NewArgVars),
+
+ % introduce a new variable
+ polymorphism__new_typeclass_info_var(VarSet1, VarTypes1,
+ ClassNameString, NewVar, VarSet, VarTypes),
+
+ % create the construction unification to initialize the
+ % variable
+ UniMode = (free - ground(shared, no) ->
+ ground(shared, no) - ground(shared, no)),
+ list__length(NewArgVars, NumArgVars),
+ list__duplicate(NumArgVars, UniMode, UniModes),
+ Unification = construct(NewVar, NewConsId, NewArgVars,
+ UniModes),
+ UnifyMode = (free -> ground(shared, no)) -
+ (ground(shared, no) -> ground(shared, no)),
+ UnifyContext = unify_context(explicit, []),
+ % XXX the UnifyContext is wrong
+ Unify = unify(NewVar, TypeClassInfoTerm, UnifyMode,
+ Unification, UnifyContext),
+
+ % create a goal_info for the unification
+ goal_info_init(GoalInfo0),
+ set__list_to_set([NewVar | NewArgVars], TheNonLocals),
+ goal_info_set_nonlocals(GoalInfo0, TheNonLocals, GoalInfo1),
+ list__duplicate(NumArgVars, ground(shared, no), ArgInsts),
+ % note that we could perhaps be more accurate than
+ % `ground(shared)', but it shouldn't make any
+ % difference.
+ InstConsId = cons( qualified("mercury_builtin", "typeclass_info"),
+ NumArgVars),
+ instmap_delta_from_assoc_list(
+ [NewVar -
+ bound(unique, [functor(InstConsId, ArgInsts)])],
+ InstMapDelta),
+ goal_info_set_instmap_delta(GoalInfo1, InstMapDelta, GoalInfo2),
+ goal_info_set_determinism(GoalInfo2, det, GoalInfo),
+
+ TypeClassInfoGoal = Unify - GoalInfo,
+ NewGoals0 = [TypeClassInfoGoal, BaseGoal],
+ list__append(SuperClassGoals, NewGoals0, NewGoals),
+ Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
+ TCVarMap, Proofs, PredName, ModuleInfo).
+
+%---------------------------------------------------------------------------%
+
+:- pred polymorphism__get_arg_superclass_vars(hlds_class_defn, list(type),
+ map(class_constraint, constraint_proof), list(var), list(hlds_goal),
+ poly_info, poly_info).
+:- mode polymorphism__get_arg_superclass_vars(in, in, in, out, out,
+ in, out) is det.
+
+polymorphism__get_arg_superclass_vars(ClassDefn, InstanceTypes,
+ SuperClassProofs, NewVars, NewGoals, Info0, Info) :-
+
+ Info0 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap0, TCVarMap0,
+ Proofs, PredName, ModuleInfo),
+
+ ClassDefn = hlds_class_defn(SuperClasses, ClassVars, _, ClassVarSet),
+
+ map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
+ varset__merge_subst(VarSet0, ClassVarSet, VarSet1, Subst),
+
+ % XXX I think the SuperClassProofs need to have the
+ % substitutions applied since the code that uses them
+ % assumes that this has already been done. (?)
+
+ Info1 = poly_info(VarSet1, VarTypes0, TVarSet, TVarMap0, TCVarMap0,
+ SuperClassProofs, PredName, ModuleInfo),
+
+ polymorphism__make_superclasses_from_proofs(SuperClasses, Subst,
+ TypeSubst, [], NewGoals, Info1, Info2, [], NewVars),
+
+ Info2 = poly_info(VarSet, VarTypes, _, TVarMap, TCVarMap, _, _, _),
+
+ Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap, TCVarMap,
+ Proofs, PredName, ModuleInfo) .
+
+
+:- pred polymorphism__make_superclasses_from_proofs(list(class_constraint),
+ substitution, tsubst, list(hlds_goal), list(hlds_goal),
+ poly_info, poly_info, list(var), list(var)).
+:- mode polymorphism__make_superclasses_from_proofs(in, in, in, in, out,
+ in, out, in, out) is det.
+
+polymorphism__make_superclasses_from_proofs([], _, _,
+ Goals, Goals, Info, Info, Vars, Vars).
+polymorphism__make_superclasses_from_proofs([C|Cs], Subst, TypeSubst,
+ Goals0, Goals, Info0, Info, Vars0, [Var|Vars]) :-
+ polymorphism__make_superclasses_from_proofs(Cs, Subst, TypeSubst,
+ Goals0, Goals1, Info0, Info1, Vars0, Vars),
+ polymorphism__make_typeclass_info_var(C, Subst, TypeSubst,
+ Goals1, Goals, [], _, Info1, Info, Var).
%---------------------------------------------------------------------------%
% Given a list of types, create a list of variables to hold the type_info
% for those types, and create a list of goals to initialize those type_info
% variables to the appropriate type_info structures for the types.
-% Update the varset and vartypes accordingly.
-:- pred polymorphism__make_vars(list(type), module_info, map(tvar, var),
- varset, map(var, type), list(var), map(tvar, var), list(hlds_goal),
- varset, map(var, type)).
-:- mode polymorphism__make_vars(in, in, in, in, in, out, out, out, out,
- out) is det.
-
-polymorphism__make_vars([], _, TypeInfoMap, VarSet, VarTypes, [], TypeInfoMap,
- [], VarSet, VarTypes).
-polymorphism__make_vars([Type | Types], ModuleInfo, TypeInfoMap0,
- VarSet0, VarTypes0, ExtraVars, TypeInfoMap, ExtraGoals,
- VarSet, VarTypes) :-
- polymorphism__make_var(Type, ModuleInfo, TypeInfoMap0,
- VarSet0, VarTypes0, Var, TypeInfoMap1, ExtraGoals1, VarSet1,
- VarTypes1),
- polymorphism__make_vars(Types, ModuleInfo, TypeInfoMap1,
- VarSet1, VarTypes1, ExtraVars2, TypeInfoMap, ExtraGoals2,
- VarSet, VarTypes),
+:- pred polymorphism__make_type_info_vars(list(type),
+ list(var), list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__make_type_info_vars(in, out, out, in, out) is det.
+
+polymorphism__make_type_info_vars([], [], [], Info, Info).
+polymorphism__make_type_info_vars([Type | Types],
+ ExtraVars, ExtraGoals, Info0, Info) :-
+ polymorphism__make_type_info_var(Type,
+ Var, ExtraGoals1, Info0, Info1),
+ polymorphism__make_type_info_vars(Types,
+ ExtraVars2, ExtraGoals2, Info1, Info),
ExtraVars = [Var | ExtraVars2],
list__append(ExtraGoals1, ExtraGoals2, ExtraGoals).
-:- pred polymorphism__make_var(type, module_info, map(tvar, var),
- varset, map(var, type), var, map(tvar, var), list(hlds_goal),
- varset, map(var, type)).
-:- mode polymorphism__make_var(in, in, in, in, in, out, out, out, out, out)
- is det.
+:- pred polymorphism__make_type_info_var(type, var, list(hlds_goal),
+ poly_info, poly_info).
+:- mode polymorphism__make_type_info_var(in, out, out, in, out) is det.
-polymorphism__make_var(Type, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
- Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes) :-
+polymorphism__make_type_info_var(Type, Var, ExtraGoals, Info0, Info) :-
(
type_is_higher_order(Type, PredOrFunc, TypeArgs)
->
@@ -754,11 +1439,11 @@
% To allow univ_to_type to check the type_infos
% correctly, the actual arity of the pred is added to
% the type_info of higher-order types.
+ % XXX fix this when contexts are added to higher order types
hlds_out__pred_or_func_to_str(PredOrFunc, PredOrFuncStr),
TypeId = unqualified(PredOrFuncStr) - 0,
polymorphism__construct_type_info(Type, TypeId, TypeArgs,
- yes, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
- Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes)
+ yes, Var, ExtraGoals, Info0, Info)
;
type_to_type_id(Type, TypeId, TypeArgs)
->
@@ -768,11 +1453,11 @@
% at the top of the module.
polymorphism__construct_type_info(Type, TypeId, TypeArgs,
- no, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
- Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes)
+ no, Var, ExtraGoals, Info0, Info)
;
Type = term__variable(TypeVar1),
- map__search(TypeInfoMap0, TypeVar1, TypeInfoVar)
+ Info0 = poly_info(_, _, _, TypeInfoMap0, _, _, _, _),
+ map__search(TypeInfoMap0, TypeVar1, TypeInfoLocn)
->
% This occurs for code where a predicate calls a polymorphic
% predicate with a bound but unknown value of the type variable.
@@ -790,11 +1475,20 @@
%
% p(TypeInfo, X) :- q(TypeInfo, X).
- Var = TypeInfoVar,
- ExtraGoals = [],
- VarSet = VarSet0,
- VarTypes = VarTypes0,
- TypeInfoMap = TypeInfoMap0
+ (
+ % If the typeinfo is available in a variable,
+ % just use it
+ TypeInfoLocn = type_info(TypeInfoVar),
+ Var = TypeInfoVar,
+ ExtraGoals = [],
+ Info = Info0
+ ;
+ % If the typeinfo is in a typeclass_info, first
+ % extract it, then use it
+ TypeInfoLocn = typeclass_info(TypeClassInfoVar, Index),
+ extract_type_info(Type, TypeVar1, TypeClassInfoVar,
+ Index, ExtraGoals, Var, Info0, Info)
+ )
;
Type = term__variable(TypeVar1)
->
@@ -829,27 +1523,28 @@
% variable to zero
TypeId = unqualified("void") - 0,
polymorphism__construct_type_info(Type, TypeId, [],
- no, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
- Var, TypeInfoMap1, ExtraGoals, VarSet, VarTypes),
- map__det_insert(TypeInfoMap1, TypeVar1, Var, TypeInfoMap)
+ no, Var, ExtraGoals, Info0, Info1),
+ Info1 = poly_info(A, B, C, TypeInfoMap1, E, F, G, H),
+ map__det_insert(TypeInfoMap1, TypeVar1, type_info(Var),
+ TypeInfoMap),
+ Info = poly_info(A, B, C, TypeInfoMap, E, F, G, H)
;
error("polymorphism__make_var: unknown type")
).
:- pred polymorphism__construct_type_info(type, type_id, list(type),
- bool, module_info, map(tvar, var), varset, map(var, type),
- var, map(tvar, var), list(hlds_goal), varset, map(var, type)).
-:- mode polymorphism__construct_type_info(in, in, in, in, in, in, in, in,
- out, out, out, out, out) is det.
+ bool, var, list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__construct_type_info(in, in, in, in, out, out,
+ in, out) is det.
polymorphism__construct_type_info(Type, TypeId, TypeArgs, IsHigherOrder,
- ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
- Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes) :-
+ Var, ExtraGoals, Info0, Info) :-
% Create the typeinfo vars for the arguments
- polymorphism__make_vars(TypeArgs, ModuleInfo, TypeInfoMap0,
- VarSet0, VarTypes0, ArgTypeInfoVars, TypeInfoMap,
- ArgTypeInfoGoals, VarSet1, VarTypes1),
+ polymorphism__make_type_info_vars(TypeArgs, ArgTypeInfoVars,
+ ArgTypeInfoGoals, Info0, Info1),
+
+ Info1 = poly_info(VarSet1, VarTypes1, C, D, E, F, G, ModuleInfo),
module_info_globals(ModuleInfo, Globals),
globals__get_type_info_method(Globals, TypeInfoMethod),
@@ -863,7 +1558,9 @@
ArgTypeInfoGoals, Type, IsHigherOrder,
BaseVar, VarSet2, VarTypes2, [BaseGoal],
Var, VarSet, VarTypes, ExtraGoals)
- ).
+ ),
+
+ Info = poly_info(VarSet, VarTypes, C, D, E, F, G, ModuleInfo).
% Create a unification for the two-cell type_info
% variable for this type if the type arity is not zero:
@@ -1201,6 +1898,8 @@
BaseTypeInfoGoal = Unify - GoalInfo.
+%---------------------------------------------------------------------------%
+
:- pred polymorphism__make_head_vars(list(tvar), tvarset,
varset, map(var, type),
list(var), varset, map(var, type)).
@@ -1240,18 +1939,336 @@
[Type], UnifyPredType),
map__set(VarTypes0, Var, UnifyPredType, VarTypes).
+%---------------------------------------------------------------------------%
+
+:- pred extract_type_info(type, tvar, var, int, list(hlds_goal),
+ var, poly_info, poly_info).
+:- mode extract_type_info(in, in, in, in, out, out, in, out) is det.
+
+extract_type_info(Type, TypeVar, TypeClassInfoVar, Index, Goals,
+ TypeInfoVar, PolyInfo0, PolyInfo) :-
+ PolyInfo0 = poly_info(VarSet0, VarTypes0, C, TypeInfoLocns0,
+ E, F, G, ModuleInfo),
+ extract_type_info_2(Type, TypeVar, TypeClassInfoVar, Index, ModuleInfo,
+ Goals, TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
+ VarSet, VarTypes, TypeInfoLocns),
+ PolyInfo = poly_info(VarSet, VarTypes, C, TypeInfoLocns, E, F, G,
+ ModuleInfo).
+
+:- pred extract_type_info_2(type, tvar, var, int, module_info, list(hlds_goal),
+ var, varset, map(var, type), map(tvar, type_info_locn),
+ varset, map(var, type), map(tvar, type_info_locn)).
+:- 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,
+ TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
+ VarSet, VarTypes, TypeInfoLocns) :-
+
+ % We need a dummy tvarset to pass to get_pred_id_and_proc_id
+ varset__init(TVarSet0),
+ varset__new_var(TVarSet0, Dummy, TVarSet),
+
+ term__context_init(EmptyContext),
+ ExtractTypeInfo = qualified("mercury_builtin",
+ "type_info_from_typeclass_info"),
+ TypeClassInfoTerm = term__functor(term__atom("typeclass_info"), [],
+ EmptyContext),
+ IntTerm = term__functor(term__atom("int"), [], EmptyContext),
+ TypeInfoTerm = term__functor(term__atom("type_info"),
+ [term__variable(Dummy)], EmptyContext),
+
+ % We have to put an extra type_info at the front, and pass it a
+ % bogus value because this pred has a type parameter... even
+ % though we are actually _extracting_ the type_info.
+ % Existential types would fix this.
+ get_pred_id_and_proc_id(ExtractTypeInfo, predicate, TVarSet,
+ [TypeClassInfoTerm, IntTerm, TypeInfoTerm],
+ 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),
+ 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),
+ 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],
+ not_builtin, no, ExtractTypeInfo) - GoalInfo,
+
+ Goals = [IndexGoal, DummyTypeInfoGoal, Call],
+
+ /* We should do this, except that makes us incorrectly compute the
+ * non-locals for the goal, since it appears to fixup_quantification
+ * that the type-info is non-local, but the typeclass-info is not.
+ % Update the location of the type_info so that we don't go to
+ % the bother of re-extracting it.
+ map__det_update(TypeInfoLocns0, TypeVar, type_info(TypeInfoVar),
+ TypeInfoLocns).
+ */
+ TypeInfoLocns = TypeInfoLocns0.
+
+%---------------------------------------------------------------------------%
+
+ % Add a head var for each class constraint, and make an entry in the
+ % typeinfo locations map for each constrained type var.
+:- pred polymorphism__make_typeclass_info_head_vars(list(class_constraint),
+ module_info, varset, map(var, type), list(var),
+ map(var, type_info_locn), list(var), varset, map(var, type)).
+:- mode polymorphism__make_typeclass_info_head_vars(in, in, in, in,
+ out, out, out, out, out) is det.
+
+polymorphism__make_typeclass_info_head_vars(ClassContext, ModuleInfo, VarSet0,
+ VarTypes0, ExtraHeadVars, TypeClassInfoMap, ConstrainedTVars,
+ VarSet, VarTypes) :-
+
+ % initialise the new accumulators
+ ExtraHeadVars0 = [],
+ map__init(TypeClassInfoMap0),
+
+ % do the work
+ polymorphism__make_typeclass_info_head_vars_2(ClassContext, ModuleInfo,
+ VarSet0, VarSet,
+ VarTypes0, VarTypes,
+ ExtraHeadVars0, ExtraHeadVars1,
+ TypeClassInfoMap0, TypeClassInfoMap),
+
+ % A type var has a location in a typeclass info iff it is
+ % constrained
+ map__keys(TypeClassInfoMap, ConstrainedTVars),
+
+ % The ExtraHeadVars are built up in reverse
+ list__reverse(ExtraHeadVars1, ExtraHeadVars).
+
+:- pred polymorphism__make_typeclass_info_head_vars_2(list(class_constraint),
+ module_info, varset, varset,
+ map(var, type), map(var, type),
+ list(var), list(var),
+ map(var, type_info_locn), map(var, type_info_locn)).
+:- mode polymorphism__make_typeclass_info_head_vars_2(in, in, in, out, in, out,
+ in, out, in, out) is det.
+
+polymorphism__make_typeclass_info_head_vars_2([], _,
+ VarSet, VarSet,
+ VarTypes, VarTypes,
+ ExtraHeadVars, ExtraHeadVars,
+ TypeInfoLocations, TypeInfoLocations).
+polymorphism__make_typeclass_info_head_vars_2([C|Cs], ModuleInfo,
+ VarSet0, VarSet,
+ VarTypes0, VarTypes,
+ ExtraHeadVars0, ExtraHeadVars,
+ TypeClassInfoMap0, TypeClassInfoMap) :-
+
+ C = constraint(ClassName0, ClassTypes),
+
+ % Work out how many superclass the class has
+ list__length(ClassTypes, ClassArity),
+ ClassId = class_id(ClassName0, ClassArity),
+ module_info_classes(ModuleInfo, ClassTable),
+ map__lookup(ClassTable, ClassId, ClassDefn),
+ ClassDefn = hlds_class_defn(SuperClasses, _, _, _),
+ list__length(SuperClasses, NumSuperClasses),
+
+ unqualify_name(ClassName0, ClassName),
+
+ % Make a new variable to contain the dictionary for this
+ % typeclass constraint
+ polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, ClassName,
+ Var, VarSet1, VarTypes1),
+ ExtraHeadVars1 = [Var | ExtraHeadVars0],
+
+ % Find all the type variables in the constraint, and remember
+ % what index they appear in in the typeclass info.
+
+ % The first type_info will be just after the superclass infos
+ First is NumSuperClasses + 1,
+ term__vars_list(ClassTypes, ClassTypeVars0),
+ MakeIndex = lambda([Elem0::in, Elem::out,
+ Index0::in, Index::out] is det,
+ (
+ Elem = Elem0 - Index0,
+ Index is Index0 + 1
+ )),
+ list__map_foldl(MakeIndex, ClassTypeVars0, ClassTypeVars, First, _),
+
+
+ % Work out which ones haven't been seen before
+ IsNew = lambda([TypeVar0::in] is semidet,
+ (
+ TypeVar0 = TypeVar - _Index,
+ \+ map__search(TypeClassInfoMap0, TypeVar, _)
+ )),
+ list__filter(IsNew, ClassTypeVars, NewClassTypeVars),
+
+ % Make an entry in the TypeInfo locations map for each new
+ % type variable. The type variable can be found at the
+ % previously calculated offset with the new typeclass_info
+ MakeEntry = lambda([IndexedTypeVar::in,
+ LocnMap0::in, LocnMap::out] is det,
+ (
+ IndexedTypeVar = TheTypeVar - Location,
+ map__det_insert(LocnMap0, TheTypeVar,
+ typeclass_info(Var, Location), LocnMap)
+ )),
+ list__foldl(MakeEntry, NewClassTypeVars,
+ TypeClassInfoMap0, TypeClassInfoMap1),
+
+ % Handle the rest of the constraints
+ polymorphism__make_typeclass_info_head_vars_2(Cs, ModuleInfo,
+ VarSet1, VarSet,
+ VarTypes1, VarTypes,
+ ExtraHeadVars1, ExtraHeadVars,
+ TypeClassInfoMap1, TypeClassInfoMap).
+
+:- pred polymorphism__new_typeclass_info_var(varset, map(var, type),
+ string, var,
+ varset, map(var, type)).
+:- mode polymorphism__new_typeclass_info_var(in, in, in, out, out, out) is det.
+
+polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, ClassName,
+ Var, VarSet, VarTypes) :-
+ % introduce new variable
+ varset__new_var(VarSet0, Var, VarSet1),
+ string__append("TypeClassInfo_for_", ClassName, Name),
+ varset__name_var(VarSet1, Var, Name, VarSet),
+
+ construct_type(qualified("mercury_builtin", "typeclass_info") - 0,
+ [], DictionaryType),
+ map__set(VarTypes0, Var, DictionaryType, VarTypes).
+
+%---------------------------------------------------------------------------%
+
+:- pred polymorphism__expand_class_method_bodies(module_info, module_info).
+:- mode polymorphism__expand_class_method_bodies(in, out) is det.
+
+polymorphism__expand_class_method_bodies(ModuleInfo0, ModuleInfo) :-
+ module_info_classes(ModuleInfo0, Classes),
+ module_info_name(ModuleInfo0, Name),
+ map__keys(Classes, ClassIds0),
+
+ % Don't expand classes from other modules
+ FromThisModule = lambda([ClassId::in] is semidet,
+ (
+ ClassId = class_id(qualified(Name, _), _)
+ )),
+ list__filter(FromThisModule, ClassIds0, ClassIds),
+
+ map__apply_to_list(ClassIds, Classes, ClassDefns),
+ list__foldl(expand_bodies, ClassDefns, ModuleInfo0, ModuleInfo).
+
+:- pred expand_bodies(hlds_class_defn, module_info, module_info).
+:- mode expand_bodies(in, in, out) is det.
+
+expand_bodies(hlds_class_defn(_, _, Interface, _), ModuleInfo0, ModuleInfo) :-
+ list__foldl2(expand_one_body, Interface, 1, _, ModuleInfo0, ModuleInfo).
+
+:- pred expand_one_body(hlds_class_proc, int, int, module_info, module_info).
+:- mode expand_one_body(in, in, out, in, out) is det.
+
+expand_one_body(hlds_class_proc(PredId, ProcId), ProcNum0, ProcNum,
+ ModuleInfo0, ModuleInfo) :-
+ module_info_preds(ModuleInfo0, PredTable0),
+ map__lookup(PredTable0, PredId, PredInfo0),
+ pred_info_procedures(PredInfo0, ProcTable0),
+ map__lookup(ProcTable0, ProcId, ProcInfo0),
+
+ pred_info_get_class_context(PredInfo0, ClassContext),
+ (
+ ClassContext = [Head|_]
+ ->
+ InstanceDictContext = Head
+ ;
+ error("expand_one_body: class method is not constrained")
+ ),
+
+ proc_info_typeclass_info_varmap(ProcInfo0, VarMap),
+ map__lookup(VarMap, InstanceDictContext, TypeClassInfoVar),
+
+ %proc_info_variables(ProcInfo0, VarSet0),
+ %proc_info_vartypes(ProcInfo0, VarTypes0),
+
+ proc_info_headvars(ProcInfo0, HeadVars0),
+ proc_info_vartypes(ProcInfo0, Types0),
+ proc_info_argmodes(ProcInfo0, Modes0),
+ proc_info_declared_determinism(ProcInfo0, Detism0),
+ (
+ Detism0 = yes(Detism1)
+ ->
+ Detism = Detism1
+ ;
+ error("missing determinism decl. How did we get this far?")
+ ),
+
+ (
+ list__nth_member_search(HeadVars0, TypeClassInfoVar, N),
+ delete_nth(HeadVars0, N, HeadVars1),
+ delete_nth(Modes0, N, Modes1)
+ ->
+ HeadVars = HeadVars1,
+ map__apply_to_list(HeadVars1, Types0, Types),
+ Modes = Modes1
+ ;
+ error("expand_one_body: typeclass_info var not found")
+ ),
+
+ BodyGoalExpr = class_method_call(TypeClassInfoVar, ProcNum0,
+ HeadVars, Types, Modes, Detism),
+
+ % Make the goal info for the call. Maybe we should re modecheck
+ % the whole thing?
+ set__list_to_set(HeadVars0, NonLocals),
+ instmap_delta_from_mode_list(HeadVars0, Modes0, ModuleInfo0,
+ InstmapDelta),
+ goal_info_init(NonLocals, InstmapDelta, Detism, GoalInfo),
+ BodyGoal = BodyGoalExpr - GoalInfo,
+
+ proc_info_set_goal(ProcInfo0, BodyGoal, ProcInfo),
+ map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
+ pred_info_set_procedures(PredInfo0, ProcTable, PredInfo),
+ map__det_update(PredTable0, PredId, PredInfo, PredTable),
+ module_info_set_preds(ModuleInfo0, PredTable, ModuleInfo),
+
+ ProcNum is ProcNum0 + 1.
+
+:- pred delete_nth(list(T)::in, int::in, list(T)::out) is semidet.
+
+delete_nth([X|Xs], N0, Result) :-
+ (
+ N0 > 1
+ ->
+ N is N0 - 1,
+ delete_nth(Xs, N, TheRest),
+ Result = [X|TheRest]
+ ;
+ Result = Xs
+ ).
+
+%---------------------------------------------------------------------------%
+
:- pred polymorphism__get_module_info(module_info, poly_info, poly_info).
:- mode polymorphism__get_module_info(out, in, out) is det.
polymorphism__get_module_info(ModuleInfo, PolyInfo, PolyInfo) :-
- PolyInfo = poly_info(_, _, _, _, _, ModuleInfo).
+ PolyInfo = poly_info(_, _, _, _, _, _, _, ModuleInfo).
:- pred polymorphism__set_module_info(module_info, poly_info, poly_info).
:- mode polymorphism__set_module_info(in, in, out) is det.
polymorphism__set_module_info(ModuleInfo, PolyInfo0, PolyInfo) :-
- PolyInfo0 = poly_info(A, B, C, D, E, _),
- PolyInfo = poly_info(A, B, C, D, E, ModuleInfo).
+ PolyInfo0 = poly_info(A, B, C, D, E, F, G, _),
+ PolyInfo = poly_info(A, B, C, D, E, F, G, ModuleInfo).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.26
diff -u -r1.26 prog_data.m
--- prog_data.m 1997/10/09 09:39:05 1.26
+++ prog_data.m 1997/10/17 05:27:20
@@ -52,11 +52,13 @@
; module_defn(varset, module_defn)
; pred(varset, sym_name, list(type_and_mode),
- maybe(determinism), condition)
+ maybe(determinism), condition,
+ list(class_constraint))
% VarNames, PredName, ArgTypes, Deterministicness, Cond
; func(varset, sym_name, list(type_and_mode), type_and_mode,
- maybe(determinism), condition)
+ maybe(determinism), condition,
+ list(class_constraint))
% VarNames, PredName, ArgTypes, ReturnType,
% Deterministicness, Cond
@@ -72,6 +74,16 @@
; pragma(pragma_type)
+ ; typeclass(list(class_constraint), classname, list(var),
+ class_interface, varset)
+ % Constraints, ClassName, ClassParams,
+ % ClassMethods, VarNames
+
+ ; instance(list(class_constraint), classname, list(type),
+ instance_interface, varset)
+ % DerivingClass, ClassName, Types,
+ % MethodInstances, VarNames
+
; nothing.
% used for items that should be ignored (currently only
% NU-Prolog `when' declarations, which are silently ignored
@@ -151,6 +163,51 @@
; check_termination(sym_name, arity).
% Predname, Arity
+
+:- type class_constraint ---> constraint(classname, list(type)).
+
+:- type classname == sym_name.
+
+:- type class_interface == list(class_method).
+
+:- type class_method ---> pred(varset, sym_name, list(type_and_mode),
+ maybe(determinism), condition,
+ list(class_constraint), term__context)
+ % VarNames, PredName, ArgTypes,
+ % Determinism, Cond
+ % ClassContext, Context
+
+ ; func(varset, sym_name, list(type_and_mode),
+ type_and_mode,
+ maybe(determinism), condition,
+ list(class_constraint), term__context)
+ % VarNames, PredName, ArgTypes,
+ % ReturnType,
+ % Determinism, Cond
+ % ClassContext, Context
+
+ ; pred_mode(varset, sym_name, list(mode),
+ maybe(determinism), condition,
+ term__context)
+ % VarNames, PredName, ArgModes,
+ % Determinism, Cond
+ % Context
+
+ ; func_mode(varset, sym_name, list(mode), mode,
+ maybe(determinism), condition,
+ term__context)
+ % VarNames, PredName, ArgModes,
+ % ReturnValueMode,
+ % Determinism, Cond
+ % Context
+ .
+
+:- type instance_method ---> func_instance(sym_name, sym_name, arity)
+ ; pred_instance(sym_name, sym_name, arity)
+ % Method, Instance, Arity
+ .
+
+:- type instance_interface == list(instance_method).
% For pragma c_code, there are two different calling conventions,
% one for C code that may recursively call Mercury code, and another
Index: compiler/prog_io.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io.m,v
retrieving revision 1.165
diff -u -r1.165 prog_io.m
--- prog_io.m 1997/11/02 12:29:13 1.165
+++ prog_io.m 1997/11/17 07:06:58
@@ -56,7 +56,7 @@
:- interface.
:- import_module prog_data.
-:- import_module list, io.
+:- import_module list, io, prog_io_util.
%-----------------------------------------------------------------------------%
@@ -93,12 +93,21 @@
:- pred search_for_file(list(string), string, bool, io__state, io__state).
:- mode search_for_file(in, in, out, di, uo) is det.
+ % parse_item(ModuleName, VarSet, Term, MaybeItem)
+ %
+ % parse Term. If successful, MaybeItem is bound to the parsed item,
+ % otherwise it is bound to an appropriate error message.
+ % Qualify appropriate parts to come from ModuleName
+:- pred parse_item(string, varset, term, maybe_item_and_context).
+:- mode parse_item(in, in, in, out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module prog_io_goal, prog_io_dcg, prog_io_pragma, prog_io_util.
+:- import_module prog_io_typeclass.
:- import_module hlds_data, hlds_pred, prog_util, globals, options, (inst).
:- import_module bool, int, string, std_util, parser, term_io, dir, require.
:- import_module varset, term.
@@ -414,9 +423,6 @@
convert_item(ok(Item, Context), ok(Item, Context)).
convert_item(error(M, T), error(M, T)).
-:- pred parse_item(string, varset, term, maybe_item_and_context).
-:- mode parse_item(in, in, in, out) is det.
-
parse_item(ModuleName, VarSet, Term, Result) :-
( %%% some [Decl, DeclContext]
Term = term__functor(term__atom(":-"), [Decl], DeclContext)
@@ -661,6 +667,12 @@
process_decl(ModuleName, VarSet, "pragma", Pragma, Result):-
parse_pragma(ModuleName, VarSet, Pragma, Result).
+process_decl(ModuleName, VarSet, "typeclass", Args, Result):-
+ parse_typeclass(ModuleName, VarSet, Args, Result).
+
+process_decl(ModuleName, VarSet, "instance", Args, Result):-
+ parse_instance(ModuleName, VarSet, Args, Result).
+
:- pred parse_type_decl(string, varset, term, maybe1(item)).
:- mode parse_type_decl(in, in, in, out) is det.
parse_type_decl(ModuleName, VarSet, TypeDecl, Result) :-
@@ -1082,22 +1094,42 @@
maybe1(item)).
:- mode process_pred(in, in, in, in, in, out) is det.
-process_pred(ModuleName, VarSet, PredType, Cond, MaybeDet, Result) :-
- parse_qualified_term(ModuleName, PredType, PredType,
- "`:- pred' declaration", R),
- process_pred_2(R, PredType, VarSet, MaybeDet, Cond, Result).
+process_pred(ModuleName, VarSet, PredType0, Cond, MaybeDet, Result) :-
+ (
+ maybe_get_class_context(ModuleName, PredType0, PredType,
+ MaybeContext)
+ ->
+ (
+ MaybeContext = ok(Constraints),
+ parse_qualified_term(ModuleName, PredType, PredType,
+ "`:- pred' declaration", R),
+ process_pred_2(R, PredType, VarSet, MaybeDet, Cond,
+ Constraints, Result)
+ ;
+ MaybeContext = error(String, Term),
+ Result = error(String, Term)
+ )
+ ;
+ parse_qualified_term(ModuleName, PredType0, PredType0,
+ "`:- pred' declaration", R),
+ process_pred_2(R, PredType0, VarSet, MaybeDet, Cond, [],
+ Result)
+ ).
:- pred process_pred_2(maybe_functor, term, varset, maybe(determinism),
- condition, maybe1(item)).
-:- mode process_pred_2(in, in, in, in, in, out) is det.
-process_pred_2(ok(F, As0), PredType, VarSet, MaybeDet, Cond, Result) :-
+ condition, list(class_constraint), maybe1(item)).
+:- mode process_pred_2(in, in, in, in, in, in, out) is det.
+
+process_pred_2(ok(F, As0), PredType, VarSet, MaybeDet, Cond, ClassContext,
+ Result) :-
(
convert_type_and_mode_list(As0, As)
->
(
verify_type_and_mode_list(As)
->
- Result = ok(pred(VarSet, F, As, MaybeDet, Cond))
+ Result = ok(pred(VarSet, F, As, MaybeDet, Cond,
+ ClassContext))
;
Result = error("some but not all arguments have modes", PredType)
)
@@ -1105,7 +1137,24 @@
Result = error("syntax error in `:- pred' declaration",
PredType)
).
-process_pred_2(error(M, T), _, _, _, _, error(M, T)).
+process_pred_2(error(M, T), _, _, _, _, _, error(M, T)).
+
+%-----------------------------------------------------------------------------%
+ % We could probably get rid of some code duplication between here and
+ % prog_io_typeclass.m
+ % The last argument is `no' if no context was given, and yes(Result) if
+ % there was. Result is either bound to the correctly parsed context, or
+ % an appropriate error message (if a syntactically invalid error
+ % message was given.
+
+:- pred maybe_get_class_context(string, term, term,
+ maybe1(list(class_constraint))).
+:- mode maybe_get_class_context(in, in, out, out) is semidet.
+
+maybe_get_class_context(ModuleName, PredType0, PredType, MaybeContext) :-
+ PredType0 = term__functor(term__atom("<="),
+ [PredType, Constraints], _),
+ parse_class_constraints(ModuleName, Constraints, MaybeContext).
%-----------------------------------------------------------------------------%
@@ -1141,7 +1190,30 @@
maybe1(item)).
:- mode process_func(in, in, in, in, in, out) is det.
-process_func(ModuleName, VarSet, Term, Cond, MaybeDet, Result) :-
+process_func(ModuleName, VarSet, Term0, Cond, MaybeDet, Result) :-
+ (
+ maybe_get_class_context(ModuleName, Term0, Term,
+ MaybeContext)
+ ->
+ (
+ MaybeContext = ok(Constraints),
+ process_unconstrained_func(ModuleName, VarSet, Term,
+ Cond, MaybeDet, Constraints, Result)
+ ;
+ MaybeContext = error(String, ErrorTerm),
+ Result = error(String, ErrorTerm)
+ )
+ ;
+ process_unconstrained_func(ModuleName, VarSet, Term0,
+ Cond, MaybeDet, [], Result)
+ ).
+
+:- pred process_unconstrained_func(string, varset, term, condition,
+ maybe(determinism), list(class_constraint), maybe1(item)).
+:- mode process_unconstrained_func(in, in, in, in, in, in, out) is det.
+
+process_unconstrained_func(ModuleName, VarSet, Term, Cond, MaybeDet,
+ Constraints, Result) :-
(
Term = term__functor(term__atom("="),
[FuncTerm, ReturnTypeTerm], _Context)
@@ -1149,16 +1221,18 @@
parse_qualified_term(ModuleName, FuncTerm, Term,
"`:- func' declaration", R),
process_func_2(R, FuncTerm, ReturnTypeTerm, VarSet, MaybeDet,
- Cond, Result)
+ Cond, Constraints, Result)
;
Result = error("`=' expected in `:- func' declaration", Term)
).
+
:- pred process_func_2(maybe_functor, term, term, varset, maybe(determinism),
- condition, maybe1(item)).
-:- mode process_func_2(in, in, in, in, in, in, out) is det.
+ condition, list(class_constraint), maybe1(item)).
+:- mode process_func_2(in, in, in, in, in, in, in, out) is det.
+
process_func_2(ok(F, As0), FuncTerm, ReturnTypeTerm, VarSet, MaybeDet, Cond,
- Result) :-
+ ClassContext, Result) :-
( convert_type_and_mode_list(As0, As) ->
( \+ verify_type_and_mode_list(As) ->
Result = error("some but not all arguments have modes",
@@ -1187,7 +1261,7 @@
FuncTerm)
;
Result = ok(func(VarSet, F, As, ReturnType,
- MaybeDet, Cond))
+ MaybeDet, Cond, ClassContext))
)
;
Result = error(
@@ -1199,7 +1273,7 @@
"syntax error in arguments of `:- func' declaration",
FuncTerm)
).
-process_func_2(error(M, T), _, _, _, _, _, error(M, T)).
+process_func_2(error(M, T), _, _, _, _, _, _, error(M, T)).
%-----------------------------------------------------------------------------%
Index: compiler/prog_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_out.m,v
retrieving revision 1.33
diff -u -r1.33 prog_out.m
--- prog_out.m 1997/07/27 15:16:38 1.33
+++ prog_out.m 1997/10/21 05:03:03
@@ -26,6 +26,10 @@
:- pred prog_out__write_context(term__context, io__state, io__state).
:- mode prog_out__write_context(in, di, uo) is det.
+:- pred prog_out__write_strings_with_context(term__context, list(string),
+ io__state, io__state).
+:- mode prog_out__write_strings_with_context(in, in, di, uo) is det.
+
:- pred prog_out__write_sym_name(sym_name, io__state, io__state).
:- mode prog_out__write_sym_name(in, di, uo) is det.
@@ -39,7 +43,7 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module require, string, list, varset, std_util, term_io.
+:- import_module require, string, list, varset, std_util, term_io, int.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -81,15 +85,62 @@
% error message.
prog_out__write_context(Context) -->
+ prog_out__write_context_2(Context, _).
+
+:- pred prog_out__write_context_2(term__context, int, io__state, io__state).
+:- mode prog_out__write_context_2(in, out, di, uo) is det.
+
+prog_out__write_context_2(Context, Length) -->
{ term__context_file(Context, FileName) },
{ term__context_line(Context, LineNumber) },
( { FileName = "" } ->
- []
+ { Length = 0 }
;
{ string__format("%s:%03d: ", [s(FileName), i(LineNumber)],
ContextMessage) },
- io__write_string(ContextMessage)
+ io__write_string(ContextMessage),
+ { string__length(ContextMessage, Length) }
).
+
+%-----------------------------------------------------------------------------%
+
+prog_out__write_strings_with_context(Context, Strings) -->
+ prog_out__write_strings_with_context_2(Context, Strings, 0).
+
+:- pred prog_out__write_strings_with_context_2(term__context, list(string), int,
+ io__state, io__state).
+:- mode prog_out__write_strings_with_context_2(in, in, in, di, uo) is det.
+
+prog_out__write_strings_with_context_2(_Context, [], _) --> [].
+prog_out__write_strings_with_context_2(Context, [S|Ss], N0) -->
+ { string__length(S, MessageLength) },
+ (
+ { N0 = 0 }
+ ->
+ prog_out__write_context_2(Context, ContextLength),
+ io__write_string(" "),
+ io__write_string(S),
+ { N is ContextLength + MessageLength },
+ { Rest = Ss }
+ ;
+ { N1 is MessageLength + N0 },
+ { num_columns(NumColumns) },
+ { N1 < NumColumns }
+ ->
+ io__write_string(S),
+ { N = N1 },
+ { Rest = Ss }
+ ;
+ io__write_char('\n'),
+ { N = 0 },
+ { Rest = [S|Ss] }
+ ),
+ prog_out__write_strings_with_context_2(Context, Rest, N).
+
+
+:- pred num_columns(int::out) is det.
+
+num_columns(80).
%-----------------------------------------------------------------------------%
Index: compiler/quantification.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/quantification.m,v
retrieving revision 1.53
diff -u -r1.53 quantification.m
--- quantification.m 1997/09/01 14:04:33 1.53
+++ quantification.m 1997/09/08 05:19:36
@@ -297,6 +297,10 @@
higher_order_call(PredVar, ArgVars, C, D, E, F)) -->
implicitly_quantify_atomic_goal([PredVar|ArgVars]).
+implicitly_quantify_goal_2(class_method_call(TCVar, B, ArgVars, D, E, F), _,
+ class_method_call(TCVar, B, ArgVars, D, E, F)) -->
+ implicitly_quantify_atomic_goal([TCVar|ArgVars]).
+
implicitly_quantify_goal_2(
unify(Var, UnifyRHS0, Mode, Unification0, UnifyContext),
Context,
@@ -589,6 +593,10 @@
quantification__goal_vars_2(higher_order_call(PredVar, ArgVars, _, _, _, _),
Set0, LambdaSet, Set, LambdaSet) :-
set__insert_list(Set0, [PredVar | ArgVars], Set).
+
+quantification__goal_vars_2(class_method_call(TCVar, _, ArgVars, _, _, _),
+ Set0, LambdaSet, Set, LambdaSet) :-
+ set__insert_list(Set0, [TCVar | ArgVars], Set).
quantification__goal_vars_2(call(_, _, ArgVars, _, _, _), Set0, LambdaSet,
Set, LambdaSet) :-
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/saved_vars.m,v
retrieving revision 1.11
diff -u -r1.11 saved_vars.m
--- saved_vars.m 1997/09/01 14:04:35 1.11
+++ saved_vars.m 1997/10/21 05:03:55
@@ -110,6 +110,10 @@
Goal = GoalExpr0 - GoalInfo0,
SlotInfo = SlotInfo0
;
+ GoalExpr0 = class_method_call(_, _, _, _, _, _),
+ Goal = GoalExpr0 - GoalInfo0,
+ SlotInfo = SlotInfo0
+ ;
GoalExpr0 = call(_, _, _, _, _, _),
Goal = GoalExpr0 - GoalInfo0,
SlotInfo = SlotInfo0
@@ -266,6 +270,15 @@
Goals = [NewConstruct, Goal1 | Goals1]
;
Goal0Expr = higher_order_call(_, _, _, _, _, _),
+ rename_var(SlotInfo0, Var, _NewVar, Subst, SlotInfo1),
+ goal_util__rename_vars_in_goal(Construct, Subst,
+ NewConstruct),
+ goal_util__rename_vars_in_goal(Goal0, Subst, Goal1),
+ saved_vars_delay_goal(Goals0, Construct, Var,
+ IsNonLocal, SlotInfo1, Goals1, SlotInfo),
+ Goals = [NewConstruct, Goal1 | Goals1]
+ ;
+ Goal0Expr = class_method_call(_, _, _, _, _, _),
rename_var(SlotInfo0, Var, _NewVar, Subst, SlotInfo1),
goal_util__rename_vars_in_goal(Construct, Subst,
NewConstruct),
Index: compiler/simplify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/simplify.m,v
retrieving revision 1.46
diff -u -r1.46 simplify.m
--- simplify.m 1997/09/01 14:04:39 1.46
+++ simplify.m 1997/10/21 05:59:38
@@ -420,6 +420,15 @@
Info = Info0
).
+ % XXX This is a little conservative, but will make no difference at
+ % this stage. We could eliminate duplicate class_method_calls, but
+ % since class_method_calls will only appear as the bodies of class
+ % methods, there will never be duplicates. If we start inlining the
+ % bodies of class methods (or other such optimisations), then adding
+ % the simplification code for class_method_calls may be worth it.
+simplify__goal_2(Goal, GoalInfo, Goal, GoalInfo, Info, Info) :-
+ Goal = class_method_call(_, _, _, _, _, _).
+
simplify__goal_2(Goal0, GoalInfo0, Goal, GoalInfo, Info0, Info) :-
Goal0 = call(PredId, ProcId, Args, IsBuiltin, _, _),
Index: compiler/store_alloc.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/store_alloc.m,v
retrieving revision 1.55
diff -u -r1.55 store_alloc.m
--- store_alloc.m 1997/09/01 14:04:44 1.55
+++ store_alloc.m 1997/09/08 05:53:33
@@ -168,6 +168,9 @@
store_alloc_in_goal_2(higher_order_call(A, B, C, D, E, F), Liveness, _, _,
higher_order_call(A, B, C, D, E, F), Liveness).
+store_alloc_in_goal_2(class_method_call(A, B, C, D, E, F), Liveness, _, _,
+ class_method_call(A, B, C, D, E, F), Liveness).
+
store_alloc_in_goal_2(call(A, B, C, D, E, F), Liveness, _, _,
call(A, B, C, D, E, F), Liveness).
Index: compiler/stratify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/stratify.m,v
retrieving revision 1.10
diff -u -r1.10 stratify.m
--- stratify.m 1997/09/01 14:04:49 1.10
+++ stratify.m 1997/10/21 06:00:32
@@ -235,6 +235,15 @@
"higher order call may introduce a non-stratified loop",
Error, Module0, Module).
+ % XXX This is very conservative.
+first_order_check_goal(class_method_call(_Var, _Num, _Vars, _Types, _Modes,
+ _Det), GInfo, _Negated, _WholeScc, ThisPredProcId, Error,
+ Module0, Module) -->
+ { goal_info_get_context(GInfo, Context) },
+ emit_message(ThisPredProcId, Context,
+ "class method call may introduce a non-stratified loop",
+ Error, Module0, Module).
+
:- pred first_order_check_goal_list(list(hlds_goal), bool,
list(pred_proc_id), pred_proc_id, bool, module_info,
module_info, io__state, io__state).
@@ -406,6 +415,22 @@
;
{ Module = Module0 }
).
+
+ % XXX Is this right? Hmmmm. I need to talk to Tom.
+higher_order_check_goal(class_method_call(_Var, _Num, _Vars, _Types, _Modes,
+ _Det), GoalInfo, Negated, _WholeScc, ThisPredProcId,
+ HighOrderLoops, Error, Module0, Module) -->
+ (
+ { Negated = yes },
+ { HighOrderLoops = yes }
+ ->
+ { goal_info_get_context(GoalInfo, Context) },
+ emit_message(ThisPredProcId, Context,
+ "higher order call may introduce a non-stratified loop",
+ Error, Module0, Module)
+ ;
+ { Module = Module0 }
+ ).
:- pred higher_order_check_goal_list(list(hlds_goal), bool, set(pred_proc_id),
pred_proc_id, bool, bool, module_info, module_info,
@@ -828,6 +853,11 @@
check_goal1(higher_order_call(_Var, _Vars, _Types, _Modes, _Det, _PredOrFUnc),
Calls, Calls, HasAT, HasAT, _, yes).
+ % record that the higher order call was made. Well... a class method
+ % call is pretty similar to a higher order call...
+check_goal1(class_method_call(_Var, _Num, _Vars, _Types, _Modes, _Det), Calls,
+ Calls, HasAT, HasAT, _, yes).
+
check_goal1(conj(Goals), Calls0, Calls, HasAT0, HasAT, CallsHO0, CallsHO) :-
check_goal_list(Goals, Calls0, Calls, HasAT0, HasAT, CallsHO0, CallsHO).
check_goal1(disj(Goals, _Follow), Calls0, Calls, HasAT0, HasAT, CallsHO0,
@@ -923,6 +953,9 @@
get_called_procs(higher_order_call(_Var, _Vars, _Types, _Modes, _Det,
_PredOrFunc), Calls, Calls).
+
+get_called_procs(class_method_call(_Var, _Num,_Vars, _Types, _Modes, _Det),
+ Calls, Calls).
get_called_procs(conj(Goals), Calls0, Calls) :-
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/switch_detection.m,v
retrieving revision 1.76
diff -u -r1.76 switch_detection.m
--- switch_detection.m 1997/09/01 14:04:54 1.76
+++ switch_detection.m 1997/09/08 06:12:35
@@ -166,6 +166,9 @@
detect_switches_in_goal_2(higher_order_call(A,B,C,D,E,F), _, _, _, _,
higher_order_call(A,B,C,D,E,F)).
+detect_switches_in_goal_2(class_method_call(A,B,C,D,E,F), _, _, _, _,
+ class_method_call(A,B,C,D,E,F)).
+
detect_switches_in_goal_2(call(A,B,C,D,E,F), _, _, _, _,
call(A,B,C,D,E,F)).
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/switch_gen.m,v
retrieving revision 1.61
diff -u -r1.61 switch_gen.m
--- switch_gen.m 1997/10/14 09:27:56 1.61
+++ switch_gen.m 1997/10/20 07:16:43
@@ -208,6 +208,7 @@
switch_gen__priority(pred_closure_tag(_, _), 6). % should never occur
switch_gen__priority(code_addr_constant(_, _), 6). % should never occur
switch_gen__priority(base_type_info_constant(_, _, _), 6).% should never occur
+switch_gen__priority(base_typeclass_info_constant(_, _, _), 6).% shouldn't occur
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
Index: compiler/term_pass1.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/term_pass1.m,v
retrieving revision 1.3
diff -u -r1.3 term_pass1.m
--- term_pass1.m 1997/10/20 04:12:41 1.3
+++ term_pass1.m 1997/10/20 07:16:46
@@ -486,6 +486,11 @@
GoalInfo, _Module, _, _PPId, Error, Offs, Offs) :-
goal_info_get_context(GoalInfo, Context),
Error = error(Context - horder_call).
+
+proc_inequalities_goal(class_method_call(_, _, _, _, _, _),
+ GoalInfo, _Module, _, _PPId, Error, Offs, Offs) :-
+ goal_info_get_context(GoalInfo, Context),
+ Error = error(Context - horder_call).
proc_inequalities_goal(switch(_SwitchVar, _CanFail, Cases, _StoreMap), GoalInfo,
Module, Info, PPId, Res, Offs0, Offs) :-
Index: compiler/term_pass2.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/term_pass2.m,v
retrieving revision 1.2
diff -u -r1.2 term_pass2.m
--- term_pass2.m 1997/10/09 09:39:18 1.2
+++ term_pass2.m 1997/10/17 05:33:30
@@ -607,6 +607,17 @@
Res = error(Context - horder_call),
Out = Out0.
+ % For now, we'll pretend that the class method call is a higher order
+ % call. In reality, we could probably analyse further than this, since
+ % we know that the method being called must come from one of the
+ % instance declarations, and we could potentially (globally) analyse
+ % these.
+termination_goal(class_method_call(_, _, _, _, _, _),
+ GoalInfo, _Module, _UnifyInfo, _CallInfo, Res, Out0, Out) :-
+ goal_info_get_context(GoalInfo, Context),
+ Res = error(Context - horder_call),
+ Out = Out0.
+
termination_goal(switch(_Var, _CanFail, Cases, _StoreMap),
_GoalInfo, Module, UnifyInfo, CallInfo, Res, Out0, Out) :-
termination_switch(Cases, Module, UnifyInfo, CallInfo,
Index: compiler/type_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/type_util.m,v
retrieving revision 1.47
diff -u -r1.47 type_util.m
--- type_util.m 1997/10/14 09:27:58 1.47
+++ type_util.m 1997/11/20 07:18:58
@@ -135,6 +135,11 @@
:- pred type_list_subsumes(list(type), list(type), tsubst).
:- mode type_list_subsumes(in, in, out) is semidet.
+ % type_list_matches_exactly(TypesA, TypesB) succeeds iff TypesA and
+ % TypesB are exactly the same module variable renaming.
+:- pred type_list_matches_exactly(list(type), list(type)).
+:- mode type_list_matches_exactly(in, in) is semidet.
+
% apply a type substitution (i.e. map from tvar -> type)
% to all the types in a variable typing (i.e. map from var -> type).
@@ -149,16 +154,32 @@
map(var, type)).
:- mode apply_rec_substitution_to_type_map(in, in, out) is det.
- % Update a map from tvar to var, 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 substititon
+ % 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, var), tsubst, map(var, var),
- map(tvar, var)).
+:- 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.
+:- pred apply_rec_subst_to_constraints(substitution, list(class_constraint),
+ list(class_constraint)).
+:- mode apply_rec_subst_to_constraints(in, in, out) is det.
+
+:- pred apply_rec_subst_to_constraint(substitution, class_constraint,
+ class_constraint).
+:- mode apply_rec_subst_to_constraint(in, in, out) is det.
+
+:- pred apply_subst_to_constraints(substitution, list(class_constraint),
+ list(class_constraint)).
+:- mode apply_subst_to_constraints(in, in, out) is det.
+
+:- pred apply_subst_to_constraint(substitution, class_constraint,
+ class_constraint).
+:- mode apply_subst_to_constraint(in, in, out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -357,7 +378,11 @@
Ctor \= qualified("mercury_builtin", "type_info"),
Ctor \= qualified("mercury_builtin", "base_type_info"),
Ctor \= unqualified("type_info"),
- Ctor \= unqualified("base_type_info").
+ Ctor \= unqualified("base_type_info"),
+ Ctor \= qualified("mercury_builtin", "typeclass_info"),
+ Ctor \= qualified("mercury_builtin", "base_typeclass_info"),
+ Ctor \= unqualified("typeclass_info"),
+ Ctor \= unqualified("base_typeclass_info").
%-----------------------------------------------------------------------------%
@@ -414,6 +439,14 @@
%-----------------------------------------------------------------------------%
+ % If this becomes a performance bottleneck, it can probably be coded
+ % more efficiently.
+type_list_matches_exactly(TypesA, TypesB) :-
+ type_list_subsumes(TypesA, TypesB, _),
+ type_list_subsumes(TypesB, TypesA, _).
+
+%-----------------------------------------------------------------------------%
+
% Types are represented as terms, but we can't just use term__unify
% because we need to avoid binding any of the "head type params"
% (the type variables that occur in the head of the clause),
@@ -639,14 +672,16 @@
).
-:- pred apply_substitutions_to_var_map_2(list(var)::in, map(tvar, var)::in,
- tsubst::in, map(var, var)::in, map(tvar, var)::in,
- map(tvar, var)::out) is det.
+:- 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,
+ 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) :-
- map__lookup(VarMap0, TVar, Var),
+ map__lookup(VarMap0, TVar, Locn),
+ type_info_locn_var(Locn, Var),
% find the new tvar, if there is one, otherwise just
% create the old var as a type variable.
@@ -662,16 +697,42 @@
;
NewVar = Var
),
+ (
+ Locn = type_info(_),
+ NewLocn = type_info(NewVar)
+ ;
+ Locn = typeclass_info(_, Num),
+ NewLocn = typeclass_info(NewVar, Num)
+ ),
% 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, NewVar, NewVarMap1)
+ map__det_insert(NewVarMap0, NewTVar, NewLocn, NewVarMap1)
;
NewVarMap1 = NewVarMap0
),
apply_substitutions_to_var_map_2(TVars, VarMap0, TSubst, Subst,
NewVarMap1, NewVarMap).
+
+%-----------------------------------------------------------------------------%
+
+apply_rec_subst_to_constraints(Subst, Constraints0, Constraints) :-
+ list__map(apply_rec_subst_to_constraint(Subst), Constraints0,
+ Constraints).
+
+apply_rec_subst_to_constraint(Subst, Constraint0, Constraint) :-
+ Constraint0 = constraint(ClassName, Types0),
+ term__apply_rec_substitution_to_list(Types0, Subst, Types),
+ Constraint = constraint(ClassName, Types).
+
+apply_subst_to_constraints(Subst, Constraints0, Constraints) :-
+ list__map(apply_subst_to_constraint(Subst), Constraints0, Constraints).
+
+apply_subst_to_constraint(Subst, Constraint0, Constraint) :-
+ Constraint0 = constraint(ClassName, Types0),
+ term__apply_substitution_to_list(Types0, Subst, Types),
+ Constraint = constraint(ClassName, Types).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.218
diff -u -r1.218 typecheck.m
--- typecheck.m 1997/11/13 06:27:30 1.218
+++ typecheck.m 1997/11/20 06:24:31
@@ -155,6 +155,17 @@
tvarset, list(type), pred_id, sym_name).
:- mode typecheck__find_matching_pred_id(in, in, in, in, out, out) is semidet.
+ % Apply context reduction to the list of class constraints by applying
+ % the instance rules or superclass rules, building up proofs for
+ % redundant constraints
+:- pred typecheck__reduce_context_by_rule_application(instance_table,
+ class_table, tsubst, tvarset, tvarset,
+ map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof),
+ list(class_constraint), list(class_constraint)).
+:- mode typecheck__reduce_context_by_rule_application(in, in, in, in, out,
+ in, out, in, out) is semidet.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -416,17 +427,35 @@
pred_info_typevarset(PredInfo0, TypeVarSet0),
pred_info_clauses_info(PredInfo0, ClausesInfo0),
pred_info_import_status(PredInfo0, Status),
+ pred_info_get_marker_list(PredInfo0, Markers),
ClausesInfo0 = clauses_info(VarSet, ExplicitVarTypes,
_OldInferredVarTypes, HeadVars, Clauses0),
(
Clauses0 = []
->
- report_error_no_clauses(PredId, PredInfo0, ModuleInfo,
- IOState0, IOState),
- MaybePredInfo = no,
- Changed = no
+ % There are no clauses for class methods.
+ % The clauses are generated later on,
+ % in polymorphism__expand_class_method_bodies
+ ( list__member(request(class_method), Markers) ->
+ IOState = IOState0,
+ % For the moment, we just insert the types
+ % of the head vars into the clauses_info
+ pred_info_arg_types(PredInfo0, _, ArgTypes),
+ map__from_corresponding_lists(HeadVars, ArgTypes,
+ VarTypes),
+ ClausesInfo = clauses_info(VarSet, VarTypes,
+ VarTypes, HeadVars, Clauses0),
+ pred_info_set_clauses_info(PredInfo0, ClausesInfo,
+ PredInfo),
+ MaybePredInfo = yes(PredInfo),
+ Changed = no
+ ;
+ report_error_no_clauses(PredId, PredInfo0, ModuleInfo,
+ IOState0, IOState),
+ MaybePredInfo = no,
+ Changed = no
+ )
;
- pred_info_get_marker_list(PredInfo0, Markers),
( list__member(request(infer_type), Markers) ->
% For a predicate whose type is inferred,
% the predicate is allowed to bind the type
@@ -436,37 +465,43 @@
% `pred foo(T1, T2, ..., TN)' by make_hlds.m.
Inferring = yes,
HeadTypeParams = [],
+ Constraints = [],
write_pred_progress_message("% Inferring type of ",
PredId, ModuleInfo, IOState0, IOState1)
;
Inferring = no,
term__vars_list(ArgTypes0, HeadTypeParams),
+ pred_info_get_class_context(PredInfo0, Constraints),
write_pred_progress_message("% Type-checking ",
PredId, ModuleInfo, IOState0, IOState1)
),
- bool(Inferring), % dummy pred call to avoid type ambiguity
typecheck_info_init(IOState1, ModuleInfo, PredId,
TypeVarSet0, VarSet, ExplicitVarTypes,
- HeadTypeParams, Status, TypeCheckInfo1),
+ HeadTypeParams, Constraints, Status,
+ TypeCheckInfo1),
typecheck_clause_list(Clauses0, HeadVars, ArgTypes0, Clauses,
TypeCheckInfo1, TypeCheckInfo2),
+ typecheck_constraints(Inferring, TypeCheckInfo2,
+ TypeCheckInfo3),
typecheck_check_for_ambiguity(whole_pred, HeadVars,
- TypeCheckInfo2, TypeCheckInfo3),
- typecheck_info_get_final_info(TypeCheckInfo3, TypeVarSet,
+ TypeCheckInfo3, TypeCheckInfo4),
+ typecheck_info_get_final_info(TypeCheckInfo4, TypeVarSet,
InferredVarTypes0),
map__optimize(InferredVarTypes0, InferredVarTypes),
ClausesInfo = clauses_info(VarSet, ExplicitVarTypes,
InferredVarTypes, HeadVars, Clauses),
pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVarSet, PredInfo2),
+ record_class_constraint_proofs(PredInfo2, TypeCheckInfo4,
+ PredInfo3),
( Inferring = no ->
- PredInfo = PredInfo2,
+ PredInfo = PredInfo3,
Changed = no
;
map__apply_to_list(HeadVars, InferredVarTypes,
ArgTypes),
- pred_info_set_arg_types(PredInfo2, TypeVarSet,
+ pred_info_set_arg_types(PredInfo3, TypeVarSet,
ArgTypes, PredInfo),
( identical_up_to_renaming(ArgTypes0, ArgTypes) ->
Changed = no
@@ -474,7 +509,7 @@
Changed = yes
)
),
- typecheck_info_get_found_error(TypeCheckInfo3, Error),
+ typecheck_info_get_found_error(TypeCheckInfo4, Error),
(
Error = yes,
MaybePredInfo = no
@@ -482,14 +517,10 @@
Error = no,
MaybePredInfo = yes(PredInfo)
),
- typecheck_info_get_io_state(TypeCheckInfo3, IOState)
+ typecheck_info_get_io_state(TypeCheckInfo4, IOState)
)
).
- % bool/1 is used to avoid a type ambiguity
-:- pred bool(bool::in) is det.
-bool(_).
-
:- pred pred_is_user_defined_equality_pred(pred_info::in, module_info::in)
is semidet.
@@ -861,6 +892,9 @@
higher_order_call(PredVar, Args, C, D, E, F)) -->
checkpoint("higher-order call"),
typecheck_higher_order_call(PredVar, Args).
+typecheck_goal_2(class_method_call(A, B, C, D, E, F),
+ class_method_call(A, B, C, D, E, F)) -->
+ { error("class_method_calls should be introduced after typechecking") }.
typecheck_goal_2(unify(A, B0, Mode, Info, UnifyContext),
unify(A, B, Mode, Info, UnifyContext)) -->
checkpoint("unify"),
@@ -907,7 +941,7 @@
TypeVars, TypeVarSet) },
{ term__var_list_to_term_list(TypeVars, Types) },
typecheck_var_has_polymorphic_type_list(Vars,
- TypeVarSet, Types)
+ TypeVarSet, Types, [])
).
%-----------------------------------------------------------------------------%
@@ -923,8 +957,11 @@
{ Arity1 is Arity + 1 },
{ PredCallId = unqualified("call")/Arity1 },
typecheck_info_set_called_predid(PredCallId),
+% XXX DGJ
+% XXX This is wrong, and needs serious thought. It will do for now.
+% XXX We need to add constraints to higher order thingies.
typecheck_var_has_polymorphic_type_list([PredVar|Args], TypeVarSet,
- [PredVarType|ArgTypes]).
+ [PredVarType|ArgTypes], []).
:- pred higher_order_pred_type(int, tvarset, type, list(type)).
:- mode higher_order_pred_type(in, out, out, out) is det.
@@ -992,9 +1029,11 @@
map__lookup(Preds, PredId, PredInfo),
pred_info_arg_types(PredInfo, PredTypeVarSet,
PredArgTypes),
+ pred_info_get_class_context(PredInfo,
+ PredClassContext),
% rename apart the type variables in
- % called predicate's arg types and then
+ % called predicate's arg types and then
% unify the types of the call arguments
% with the called predicates' arg types
% (optimize for the common case of
@@ -1002,12 +1041,23 @@
( varset__is_empty(PredTypeVarSet) ->
typecheck_var_has_type_list(Args,
PredArgTypes, 0, TypeCheckInfo1,
- TypeCheckInfo)
+ TypeCheckInfo2),
+ (
+ % sanity check
+ PredClassContext \= []
+ ->
+ error("non-polymorphic pred has context")
+ ;
+ true
+ )
;
typecheck_var_has_polymorphic_type_list(
Args, PredTypeVarSet, PredArgTypes,
- TypeCheckInfo1, TypeCheckInfo)
- )
+ PredClassContext,
+ TypeCheckInfo1, TypeCheckInfo2)
+ ),
+ % Should we really do this now?
+ perform_context_reduction(TypeCheckInfo2, TypeCheckInfo)
;
typecheck_info_get_pred_import_status(TypeCheckInfo1,
CallingStatus),
@@ -1109,8 +1159,9 @@
TypeAssignSet0, ArgsTypeAssignSet0, ArgsTypeAssignSet) :-
map__lookup(Preds, PredId, PredInfo),
pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes),
+ pred_info_get_class_context(PredInfo, PredClassContext),
rename_apart(TypeAssignSet0, PredTypeVarSet, PredArgTypes,
- ArgsTypeAssignSet0, ArgsTypeAssignSet1),
+ PredClassContext, ArgsTypeAssignSet0, ArgsTypeAssignSet1),
get_overloaded_pred_arg_types(PredIds, Preds, CallingPredStatus,
TypeAssignSet0, ArgsTypeAssignSet1, ArgsTypeAssignSet).
@@ -1203,42 +1254,49 @@
% assignment set", and then for each arg type assignment in the
% arg type assignment set, check that the argument variables have
% the expected types.
+ % A set of class constraints are also passed in, which must have the
+ % types contained within renamed apart.
:- pred typecheck_var_has_polymorphic_type_list(list(var), tvarset, list(type),
- typecheck_info, typecheck_info).
-:- mode typecheck_var_has_polymorphic_type_list(in, in, in,
+ list(class_constraint), typecheck_info, typecheck_info).
+:- mode typecheck_var_has_polymorphic_type_list(in, in, in, in,
typecheck_info_di, typecheck_info_uo) is det.
typecheck_var_has_polymorphic_type_list(Args, PredTypeVarSet, PredArgTypes,
- TypeCheckInfo0, TypeCheckInfo) :-
+ PredClassConstraints, TypeCheckInfo0, TypeCheckInfo) :-
typecheck_info_get_type_assign_set(TypeCheckInfo0, TypeAssignSet0),
rename_apart(TypeAssignSet0, PredTypeVarSet, PredArgTypes,
- [], ArgsTypeAssignSet),
+ PredClassConstraints, [], ArgsTypeAssignSet),
typecheck_var_has_arg_type_list(Args, 0, ArgsTypeAssignSet,
TypeCheckInfo0, TypeCheckInfo).
:- pred rename_apart(type_assign_set, tvarset, list(type),
+ list(class_constraint),
args_type_assign_set, args_type_assign_set).
-:- mode rename_apart(in, in, in, in, out) is det.
+:- mode rename_apart(in, in, in, in, in, out) is det.
-rename_apart([], _, _, ArgTypeAssigns, ArgTypeAssigns).
+rename_apart([], _, _, _, ArgTypeAssigns, ArgTypeAssigns).
rename_apart([TypeAssign0 | TypeAssigns0], PredTypeVarSet, PredArgTypes0,
- ArgTypeAssigns0, ArgTypeAssigns) :-
+ PredClassConstraints0, ArgTypeAssigns0, ArgTypeAssigns) :-
type_assign_rename_apart(TypeAssign0, PredTypeVarSet, PredArgTypes0,
- TypeAssign, PredArgTypes),
- ArgTypeAssigns1 = [TypeAssign - PredArgTypes | ArgTypeAssigns0],
+ TypeAssign, PredArgTypes, Subst),
+ apply_subst_to_constraints(Subst, PredClassConstraints0,
+ PredClassConstraints),
+ NewArgTypeAssign = args(TypeAssign, PredArgTypes, PredClassConstraints),
+ ArgTypeAssigns1 = [NewArgTypeAssign | ArgTypeAssigns0],
rename_apart(TypeAssigns0, PredTypeVarSet, PredArgTypes0,
- ArgTypeAssigns1, ArgTypeAssigns).
+ PredClassConstraints0, ArgTypeAssigns1, ArgTypeAssigns).
:- pred type_assign_rename_apart(type_assign, tvarset, list(type),
- type_assign, list(type)).
-:- mode type_assign_rename_apart(in, in, in, out, out) is det.
+ type_assign, list(type), substitution).
+:- mode type_assign_rename_apart(in, in, in, out, out, out) is det.
type_assign_rename_apart(TypeAssign0, PredTypeVarSet, PredArgTypes0,
- TypeAssign, PredArgTypes) :-
+ TypeAssign, PredArgTypes, Subst) :-
type_assign_get_typevarset(TypeAssign0, TypeVarSet0),
- varset__merge(TypeVarSet0, PredTypeVarSet, PredArgTypes0,
- TypeVarSet, PredArgTypes),
+ varset__merge_subst(TypeVarSet0, PredTypeVarSet, TypeVarSet, Subst),
+ term__apply_substitution_to_list(PredArgTypes0, Subst,
+ PredArgTypes),
type_assign_set_typevarset(TypeAssign0, TypeVarSet, TypeAssign).
%-----------------------------------------------------------------------------%
@@ -1267,10 +1325,19 @@
:- mode convert_args_type_assign_set(in, out) is det.
convert_args_type_assign_set([], []).
-convert_args_type_assign_set([TypeAssign - Args | ArgTypeAssigns],
- [TypeAssign | TypeAssigns]) :-
+convert_args_type_assign_set(
+ [args(TypeAssign0, Args, Constraints0)|ArgTypeAssigns],
+ [TypeAssign | TypeAssigns]) :-
( Args = [] ->
- true
+ type_assign_get_typeclass_constraints(TypeAssign0,
+ OldConstraints),
+ type_assign_get_type_bindings(TypeAssign0, Bindings),
+ apply_rec_subst_to_constraints(Bindings, Constraints0,
+ Constraints),
+
+ list__append(Constraints, OldConstraints, NewConstraints),
+ type_assign_set_typeclass_constraints(TypeAssign0,
+ NewConstraints, TypeAssign)
;
% this should never happen, since the arguments should
% all have been processed at this point
@@ -1310,8 +1377,8 @@
:- mode skip_arg(in, out) is det.
skip_arg([], []).
-skip_arg([TypeAssign - Args0 | ArgTypeAssigns0],
- [TypeAssign - Args| ArgTypeAssigns]) :-
+skip_arg([args(TypeAssign, Args0, Constraints) | ArgTypeAssigns0],
+ [args(TypeAssign, Args, Constraints)| ArgTypeAssigns]) :-
( Args0 = [_ | Args1] ->
Args = Args1
;
@@ -1325,18 +1392,20 @@
:- mode typecheck_var_has_arg_type_2(in, in, in, in, out) is det.
typecheck_var_has_arg_type_2([], _, _) --> [].
-typecheck_var_has_arg_type_2([TypeAssign0 - ArgTypes0 | TypeAssignSet0],
- HeadTypeParams, VarId) -->
+typecheck_var_has_arg_type_2(
+ [args(TypeAssign0, ArgTypes0, ClassContext) | TypeAssignSet0],
+ HeadTypeParams, VarId) -->
arg_type_assign_var_has_type(TypeAssign0, ArgTypes0,
- HeadTypeParams, VarId),
+ HeadTypeParams, VarId, ClassContext),
typecheck_var_has_arg_type_2(TypeAssignSet0, HeadTypeParams, VarId).
:- pred arg_type_assign_var_has_type(type_assign, list(type), headtypes, var,
+ list(class_constraint),
args_type_assign_set, args_type_assign_set).
-:- mode arg_type_assign_var_has_type(in, in, in, in, in, out) is det.
+:- mode arg_type_assign_var_has_type(in, in, in, in, in, in, out) is det.
arg_type_assign_var_has_type(TypeAssign0, ArgTypes0, HeadTypeParams, VarId,
- ArgTypeAssignSet0, ArgTypeAssignSet) :-
+ ClassContext, ArgTypeAssignSet0, ArgTypeAssignSet) :-
type_assign_get_var_types(TypeAssign0, VarTypes0),
( ArgTypes0 = [Type | ArgTypes] ->
(
@@ -1346,15 +1415,17 @@
type_assign_unify_type(TypeAssign0, HeadTypeParams,
VarType, Type, TypeAssign1)
->
- ArgTypeAssignSet = [TypeAssign1 - ArgTypes |
- ArgTypeAssignSet0]
+ ArgTypeAssignSet =
+ [args(TypeAssign1, ArgTypes, ClassContext) |
+ ArgTypeAssignSet0]
;
ArgTypeAssignSet = ArgTypeAssignSet0
)
;
map__det_insert(VarTypes0, VarId, Type, VarTypes),
type_assign_set_var_types(TypeAssign0, VarTypes, TypeAssign),
- ArgTypeAssignSet = [TypeAssign - ArgTypes | ArgTypeAssignSet0]
+ ArgTypeAssignSet = [args(TypeAssign, ArgTypes, ClassContext)
+ | ArgTypeAssignSet0]
)
;
error("arg_type_assign_var_has_type")
@@ -1448,7 +1519,8 @@
:- pred get_arg_type_stuff(args_type_assign_set, var, list(arg_type_stuff)).
:- mode get_arg_type_stuff(in, in, out) is det.
get_arg_type_stuff([], _VarId, []).
-get_arg_type_stuff([TypeAssign - ArgTypes | ArgTypeAssigns], VarId, L) :-
+get_arg_type_stuff([args(TypeAssign, ArgTypes, _) | ArgTypeAssigns],
+ VarId, L) :-
get_arg_type_stuff(ArgTypeAssigns, VarId, L0),
type_assign_get_type_bindings(TypeAssign, TypeBindings),
type_assign_get_typevarset(TypeAssign, TVarSet),
@@ -1793,7 +1865,12 @@
:- type cons_type ---> cons_type(type, list(type)).
:- type cons_type_assign_set == list(pair(type_assign, cons_type)).
-:- type args_type_assign_set == list(pair(type_assign, list(type))).
+:- type args_type_assign_set == list(args_type_assign).
+
+:- type args_type_assign ---> args(type_assign, list(type),
+ list(class_constraint)).
+ % Type assignment, types of callee,
+ % constraints from callee
:- pred typecheck_unify_var_functor_get_ctors(type_assign_set,
typecheck_info, list(cons_type_info),
@@ -1857,7 +1934,7 @@
is det.
typecheck_functor_arg_types([], _, _) --> [].
-typecheck_functor_arg_types([TypeAssign - ArgTypes | ConsTypeAssigns],
+typecheck_functor_arg_types([args(TypeAssign, ArgTypes, _) | ConsTypeAssigns],
Args, TypeCheckInfo) -->
type_assign_var_has_type_list(Args, ArgTypes, TypeAssign,
TypeCheckInfo),
@@ -1969,15 +2046,22 @@
type_assign_unify_type(TypeAssign1, HeadTypeParams,
ConsType, TypeY, TypeAssign2)
->
- TypeAssignSet = [TypeAssign2 - ArgTypes |
+ % The constraints are empty here because
+ % none are added by unification with a
+ % functor
+ TypeAssignSet = [args(TypeAssign2, ArgTypes, []) |
TypeAssignSet0]
;
TypeAssignSet = TypeAssignSet0
)
;
+ % The constraints are empty here because
+ % none are added by unification with a
+ % functor
map__det_insert(VarTypes0, Y, ConsType, VarTypes),
type_assign_set_var_types(TypeAssign1, VarTypes, TypeAssign3),
- TypeAssignSet = [TypeAssign3 - ArgTypes | TypeAssignSet0]
+ TypeAssignSet = [args(TypeAssign3, ArgTypes, []) |
+ TypeAssignSet0]
).
%-----------------------------------------------------------------------------%
@@ -2007,7 +2091,7 @@
;
type_assign_rename_apart(TypeAssign0, ConsTypeVarSet,
[ConsType0 | ArgTypes0],
- TypeAssign1, [ConsType1 | ArgTypes1])
+ TypeAssign1, [ConsType1 | ArgTypes1], _)
->
ConsType = ConsType1,
ArgTypes = ArgTypes1,
@@ -2295,6 +2379,9 @@
headtypes, % Head type params
+ list(class_constraint),
+ % The declared typeclass constraints
+
bool, % Have we already warned about
% highly ambiguous overloading?
import_status
@@ -2346,24 +2433,28 @@
%-----------------------------------------------------------------------------%
:- pred typecheck_info_init(io__state, module_info, pred_id, varset,
- varset, map(var, type), headtypes, import_status, typecheck_info).
-:- mode typecheck_info_init(di, in, in, in, in, in, in, in, typecheck_info_uo)
+ varset, map(var, type), headtypes, list(class_constraint),
+ import_status, typecheck_info).
+:- mode typecheck_info_init(di, in, in, in, in, in, in, in, in,
+ typecheck_info_uo)
is det.
typecheck_info_init(IOState0, ModuleInfo, PredId, TypeVarSet, VarSet,
- VarTypes, HeadTypeParams, Status, TypeCheckInfo) :-
+ VarTypes, HeadTypeParams, Constraints, Status, TypeCheckInfo) :-
CallPredId = unqualified("") / 0,
term__context_init(Context),
map__init(TypeBindings),
+ map__init(Proofs),
FoundTypeError = no,
WarnedAboutOverloading = no,
unsafe_promise_unique(IOState0, IOState), % XXX
TypeCheckInfo = typecheck_info(
IOState, ModuleInfo, CallPredId, 0, PredId, Context,
- unify_context(explicit, []),
- VarSet, [type_assign(VarTypes, TypeVarSet, TypeBindings)],
- FoundTypeError, HeadTypeParams, WarnedAboutOverloading,
- Status
+ unify_context(explicit, []), VarSet,
+ [type_assign(VarTypes, TypeVarSet, TypeBindings,
+ Constraints, Proofs)],
+ FoundTypeError, HeadTypeParams, Constraints,
+ WarnedAboutOverloading, Status
).
%-----------------------------------------------------------------------------%
@@ -2371,7 +2462,7 @@
:- pred typecheck_info_get_io_state(typecheck_info, io__state).
:- mode typecheck_info_get_io_state(typecheck_info_get_io_state, uo) is det.
-typecheck_info_get_io_state(typecheck_info(IOState0,_,_,_,_,_,_,_,_,_,_,_,_),
+typecheck_info_get_io_state(typecheck_info(IOState0,_,_,_,_,_,_,_,_,_,_,_,_,_),
IOState) :-
unsafe_promise_unique(IOState0, IOState). % XXX
@@ -2381,8 +2472,9 @@
:- mode typecheck_info_set_io_state(typecheck_info_set_io_state, di,
typecheck_info_uo) is det.
-typecheck_info_set_io_state(typecheck_info(_,B,C,D,E,F,G,H,I,J,K,L,M), IOState0,
- typecheck_info(IOState,B,C,D,E,F,G,H,I,J,K,L,M)) :-
+typecheck_info_set_io_state(typecheck_info(_,B,C,D,E,F,G,H,I,J,K,L,M,N),
+ IOState0,
+ typecheck_info(IOState,B,C,D,E,F,G,H,I,J,K,L,M,N)) :-
unsafe_promise_unique(IOState0, IOState). % XXX
%-----------------------------------------------------------------------------%
@@ -2391,7 +2483,7 @@
:- mode typecheck_info_get_module_name(in, out) is det.
typecheck_info_get_module_name(TypeCheckInfo, Name) :-
- TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_),
+ TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_,_),
module_info_name(ModuleInfo, Name).
%-----------------------------------------------------------------------------%
@@ -2400,7 +2492,7 @@
:- mode typecheck_info_get_module_info(in, out) is det.
typecheck_info_get_module_info(TypeCheckInfo, ModuleInfo) :-
- TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_).
+ TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2408,7 +2500,7 @@
:- mode typecheck_info_get_preds(in, out) is det.
typecheck_info_get_preds(TypeCheckInfo, Preds) :-
- TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_),
+ TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_,_),
module_info_get_predicate_table(ModuleInfo, Preds).
%-----------------------------------------------------------------------------%
@@ -2417,7 +2509,7 @@
:- mode typecheck_info_get_types(in, out) is det.
typecheck_info_get_types(TypeCheckInfo, Types) :-
- TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_),
+ TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_,_),
module_info_types(ModuleInfo, Types).
%-----------------------------------------------------------------------------%
@@ -2426,7 +2518,7 @@
:- mode typecheck_info_get_ctors(in, out) is det.
typecheck_info_get_ctors(TypeCheckInfo, Ctors) :-
- TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_),
+ TypeCheckInfo = typecheck_info(_,ModuleInfo,_,_,_,_,_,_,_,_,_,_,_,_),
module_info_ctors(ModuleInfo, Ctors).
%-----------------------------------------------------------------------------%
@@ -2435,7 +2527,7 @@
:- mode typecheck_info_get_called_predid(in, out) is det.
typecheck_info_get_called_predid(TypeCheckInfo, PredId) :-
- TypeCheckInfo = typecheck_info(_,_,PredId,_,_,_,_,_,_,_,_,_,_).
+ TypeCheckInfo = typecheck_info(_,_,PredId,_,_,_,_,_,_,_,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2445,8 +2537,8 @@
typecheck_info_uo) is det.
typecheck_info_set_called_predid(PredCallId, TypeCheckInfo0, TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,_,D,E,F,G,H,I,J,K,L,M),
- TypeCheckInfo = typecheck_info(A,B,PredCallId,D,E,F,G,H,I,J,K,L,M).
+ TypeCheckInfo0 = typecheck_info(A,B,_,D,E,F,G,H,I,J,K,L,M,N),
+ TypeCheckInfo = typecheck_info(A,B,PredCallId,D,E,F,G,H,I,J,K,L,M,N).
%-----------------------------------------------------------------------------%
@@ -2454,7 +2546,7 @@
:- mode typecheck_info_get_arg_num(in, out) is det.
typecheck_info_get_arg_num(TypeCheckInfo, ArgNum) :-
- TypeCheckInfo = typecheck_info(_,_,_,ArgNum,_,_,_,_,_,_,_,_,_).
+ TypeCheckInfo = typecheck_info(_,_,_,ArgNum,_,_,_,_,_,_,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2463,8 +2555,8 @@
typecheck_info_uo) is det.
typecheck_info_set_arg_num(ArgNum, TypeCheckInfo0, TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,C,_,E,F,G,H,I,J,K,L,M),
- TypeCheckInfo = typecheck_info(A,B,C,ArgNum,E,F,G,H,I,J,K,L,M).
+ TypeCheckInfo0 = typecheck_info(A,B,C,_,E,F,G,H,I,J,K,L,M,N),
+ TypeCheckInfo = typecheck_info(A,B,C,ArgNum,E,F,G,H,I,J,K,L,M,N).
%-----------------------------------------------------------------------------%
@@ -2472,7 +2564,7 @@
:- mode typecheck_info_get_predid(in, out) is det.
typecheck_info_get_predid(TypeCheckInfo, PredId) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,PredId,_,_,_,_,_,_,_,_).
+ TypeCheckInfo = typecheck_info(_,_,_,_,PredId,_,_,_,_,_,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2480,7 +2572,7 @@
:- mode typecheck_info_get_context(in, out) is det.
typecheck_info_get_context(TypeCheckInfo, Context) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,_,Context,_,_,_,_,_,_,_).
+ TypeCheckInfo = typecheck_info(_,_,_,_,_,Context,_,_,_,_,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2490,8 +2582,8 @@
typecheck_info_uo) is det.
typecheck_info_set_context(Context, TypeCheckInfo0, TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,C,D,E,_,G,H,I,J,K,L,M),
- TypeCheckInfo = typecheck_info(A,B,C,D,E,Context,G,H,I,J,K,L,M).
+ TypeCheckInfo0 = typecheck_info(A,B,C,D,E,_,G,H,I,J,K,L,M,N),
+ TypeCheckInfo = typecheck_info(A,B,C,D,E,Context,G,H,I,J,K,L,M,N).
%-----------------------------------------------------------------------------%
@@ -2499,7 +2591,7 @@
:- mode typecheck_info_get_unify_context(in, out) is det.
typecheck_info_get_unify_context(TypeCheckInfo, UnifyContext) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,_,_,UnifyContext,_,_,_,_,_,_).
+ TypeCheckInfo = typecheck_info(_,_,_,_,_,_,UnifyContext,_,_,_,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2509,8 +2601,8 @@
typecheck_info_uo) is det.
typecheck_info_set_unify_context(UnifyContext, TypeCheckInfo0, TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,_,H,I,J,K,L,M),
- TypeCheckInfo = typecheck_info(A,B,C,D,E,F,UnifyContext,H,I,J,K,L,M).
+ TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,_,H,I,J,K,L,M,N),
+ TypeCheckInfo = typecheck_info(A,B,C,D,E,F,UnifyContext,H,I,J,K,L,M,N).
%-----------------------------------------------------------------------------%
@@ -2518,7 +2610,7 @@
:- mode typecheck_info_get_varset(in, out) is det.
typecheck_info_get_varset(TypeCheckInfo, VarSet) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,VarSet,_,_,_,_,_).
+ TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,VarSet,_,_,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2526,7 +2618,7 @@
:- mode typecheck_info_get_type_assign_set(in, out) is det.
typecheck_info_get_type_assign_set(TypeCheckInfo, TypeAssignSet) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,TypeAssignSet,_,_,_,_).
+ TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,TypeAssignSet,_,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2632,8 +2724,8 @@
typecheck_info_set_type_assign_set(TypeCheckInfo0, TypeAssignSet,
TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,_,J,K,L,M),
- TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,TypeAssignSet,J,K,L,M).
+ TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,_,J,K,L,M,N),
+ TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,TypeAssignSet,J,K,L,M,N).
%-----------------------------------------------------------------------------%
@@ -2641,7 +2733,7 @@
:- mode typecheck_info_get_found_error(typecheck_info_ui, out) is det.
typecheck_info_get_found_error(TypeCheckInfo, FoundError) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,_,FoundError,_,_,_).
+ TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,_,FoundError,_,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2650,8 +2742,8 @@
typecheck_info_uo) is det.
typecheck_info_set_found_error(TypeCheckInfo0, FoundError, TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,_,K,L,M),
- TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,I,FoundError,K,L,M).
+ TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,_,K,L,M,N),
+ TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,I,FoundError,K,L,M,N).
%-----------------------------------------------------------------------------%
@@ -2659,7 +2751,8 @@
:- mode typecheck_info_get_head_type_params(typecheck_info_ui, out) is det.
typecheck_info_get_head_type_params(TypeCheckInfo, HeadTypeParams) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,_,_,HeadTypeParams,_,_).
+ TypeCheckInfo =
+ typecheck_info(_,_,_,_,_,_,_,_,_,_,HeadTypeParams,_,_,_).
%-----------------------------------------------------------------------------%
@@ -2670,8 +2763,31 @@
typecheck_info_set_head_type_params(TypeCheckInfo0, HeadTypeParams,
TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,J,_,L,M),
- TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,I,J,HeadTypeParams,L,M).
+ TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,J,_,L,M,N),
+ TypeCheckInfo =
+ typecheck_info(A,B,C,D,E,F,G,H,I,J,HeadTypeParams,L,M,N).
+
+%-----------------------------------------------------------------------------%
+
+:- pred typecheck_info_get_constraints(typecheck_info, list(class_constraint)).
+:- mode typecheck_info_get_constraints(typecheck_info_ui, out) is det.
+
+typecheck_info_get_constraints(TypeCheckInfo, Constraints) :-
+ TypeCheckInfo =
+ typecheck_info(_,_,_,_,_,_,_,_,_,_,_,Constraints,_,_).
+
+%-----------------------------------------------------------------------------%
+
+:- pred typecheck_info_set_constraints(typecheck_info,
+ list(class_constraint), typecheck_info).
+:- mode typecheck_info_set_constraints(typecheck_info_di, in,
+ typecheck_info_uo) is det.
+
+typecheck_info_set_constraints(TypeCheckInfo0, Constraints,
+ TypeCheckInfo) :-
+ TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,_,M,N),
+ TypeCheckInfo =
+ typecheck_info(A,B,C,D,E,F,G,H,I,J,K,Constraints,M,N).
%-----------------------------------------------------------------------------%
@@ -2680,7 +2796,7 @@
is det.
typecheck_info_get_warned_about_overloading(TypeCheckInfo, Warned) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,_,_,_,Warned,_).
+ TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,_,_,_,_,Warned,_).
%-----------------------------------------------------------------------------%
@@ -2691,8 +2807,8 @@
typecheck_info_set_warned_about_overloading(TypeCheckInfo0, Warned,
TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,_,M),
- TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,Warned,M).
+ TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,L,_,N),
+ TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,L,Warned,N).
%-----------------------------------------------------------------------------%
@@ -2700,7 +2816,7 @@
:- mode typecheck_info_get_pred_import_status(typecheck_info_ui, out) is det.
typecheck_info_get_pred_import_status(TypeCheckInfo, Status) :-
- TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,_,_,_,_,Status).
+ TypeCheckInfo = typecheck_info(_,_,_,_,_,_,_,_,_,_,_,_,_,Status).
:- pred typecheck_info_set_pred_import_status(typecheck_info, import_status,
typecheck_info).
@@ -2708,8 +2824,8 @@
typecheck_info_uo) is det.
typecheck_info_set_pred_import_status(TypeCheckInfo0, Status, TypeCheckInfo) :-
- TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,L,_),
- TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,L,Status).
+ TypeCheckInfo0 = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,L,M,_),
+ TypeCheckInfo = typecheck_info(A,B,C,D,E,F,G,H,I,J,K,L,M,Status).
%-----------------------------------------------------------------------------%
@@ -2774,6 +2890,387 @@
ConsInfoList = ConsInfoList1
).
+ % Add a set of constraints to each type_assign in the typecheck info.
+:- pred typecheck_info_add_type_assign_constraints(list(class_constraint),
+ typecheck_info, typecheck_info).
+:- mode typecheck_info_add_type_assign_constraints(in, typecheck_info_di,
+ typecheck_info_uo) is det.
+
+typecheck_info_add_type_assign_constraints(NewConstraints, TypecheckInfo0,
+ TypecheckInfo) :-
+ typecheck_info_get_type_assign_set(TypecheckInfo0, TypeAssignSet0),
+ AddConstraints = lambda([TypeAssign0::in, TypeAssign::out] is det,
+ (
+ type_assign_get_typeclass_constraints(TypeAssign0,
+ OldConstraints),
+ list__append(NewConstraints, OldConstraints, Constraints),
+ type_assign_set_typeclass_constraints(TypeAssign0,
+ Constraints, TypeAssign)
+ )),
+ list__map(AddConstraints, TypeAssignSet0, TypeAssignSet),
+ typecheck_info_set_type_assign_set(TypecheckInfo0, TypeAssignSet,
+ TypecheckInfo).
+
+%-----------------------------------------------------------------------------%
+
+ % typecheck_constraints(Inferring, TypeCheckInfo0, TypeCheckInfo)
+ %
+ % Produces TypeCheckInfo from TypeCheckInfo0 by rejecting any
+ % type_assign in TypeCheckInfo0 whose calculated typeclass constraints
+ % do not match the declared constraints.
+ %
+ % An appropriate error message is given if all type_assigns are
+ % rejected.
+:- pred typecheck_constraints(bool, typecheck_info, typecheck_info).
+:- mode typecheck_constraints(in, typecheck_info_di, typecheck_info_uo) is det.
+
+ % XXX if we're inferring, don't bother checking the constraints at this
+ % XXX stage. Fix this up.
+typecheck_constraints(yes, TypeCheckInfo, TypeCheckInfo).
+typecheck_constraints(no, TypeCheckInfo0, TypeCheckInfo) :-
+ %get the declared constraints
+ typecheck_info_get_constraints(TypeCheckInfo0, DeclaredConstraints),
+
+ typecheck_info_get_type_assign_set(TypeCheckInfo0, TypeAssignSet0),
+
+ ConstraintsMatch = lambda([TypeAssign::in] is semidet,
+ (
+ type_assign_get_typeclass_constraints(TypeAssign,
+ CalculatedConstraints0),
+ type_assign_get_type_bindings(TypeAssign, Bindings),
+ apply_rec_subst_to_constraints(Bindings,
+ CalculatedConstraints0, CalculatedConstraints1),
+ list__sort_and_remove_dups(CalculatedConstraints1,
+ CalculatedConstraints),
+ % XXX. This needs thought. _When_ exactly
+ % do two constraint sets match? This is
+ % certainly too strict.
+ CalculatedConstraints = DeclaredConstraints
+ )),
+
+ % reject any type assignment whose constraints don't match the
+ % declared ones
+ list__filter(ConstraintsMatch, TypeAssignSet0, TypeAssignSet),
+ (
+ % Check that we haven't just eliminated
+ % all the type assignments.
+ TypeAssignSet = [],
+ TypeAssignSet0 \= []
+ ->
+ report_unsatisfied_constraints(TypeAssignSet0,
+ TypeCheckInfo0, TypeCheckInfo)
+ ;
+ typecheck_info_set_type_assign_set(TypeCheckInfo0,
+ TypeAssignSet, TypeCheckInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred report_unsatisfied_constraints(type_assign_set,
+ typecheck_info, typecheck_info).
+:- mode report_unsatisfied_constraints(in,
+ typecheck_info_di, typecheck_info_uo) is det.
+
+report_unsatisfied_constraints(TypeAssignSet, TypeCheckInfo0, TypeCheckInfo) :-
+ typecheck_info_get_io_state(TypeCheckInfo0, IOState0),
+
+ typecheck_info_get_constraints(TypeCheckInfo0, DeclaredConstraints),
+
+ typecheck_info_get_context(TypeCheckInfo0, Context),
+ write_context_and_pred_id(TypeCheckInfo0, IOState0, IOState1),
+ prog_out__write_context(Context, IOState1, IOState2),
+ io__write_string(" unsatisfied typeclass constraint(s):\n",
+ IOState2, IOState3),
+
+ WriteConstraints = lambda([TheTypeAssign::in, IO0::di, IO::uo] is det,
+ (
+ type_assign_get_typeclass_constraints(
+ TheTypeAssign, TheConstraints0),
+ type_assign_get_typevarset(TheTypeAssign, TheVarSet),
+ type_assign_get_type_bindings(TheTypeAssign, Bindings),
+ apply_rec_subst_to_constraints(Bindings,
+ TheConstraints0, TheConstraints1),
+ list__sort_and_remove_dups(TheConstraints1,
+ TheConstraints),
+ list__delete_elems(TheConstraints, DeclaredConstraints,
+ Unsatisfied),
+ prog_out__write_context(Context, IO0, IO1),
+ io__write_list(Unsatisfied, ", ",
+ mercury_output_constraint(TheVarSet), IO1, IO2),
+ io__write_char('\n', IO2, IO)
+ )),
+
+ % XXX this won't be very pretty when there are
+ % XXX multiple type_assigns.
+ io__write_list(TypeAssignSet, "\n", WriteConstraints,
+ IOState3, IOState),
+
+ typecheck_info_set_io_state(TypeCheckInfo0, IOState, TypeCheckInfo1),
+ typecheck_info_set_found_error(TypeCheckInfo1, yes, TypeCheckInfo).
+
+%-----------------------------------------------------------------------------%
+
+% perform_context_reduction(TypeCheckInfo0, TypeCheckInfo) is true iff
+% TypeCheckInfo is the typecheck_info that results from performing
+% context reduction on the type_assigns in TypeCheckInfo0.
+%
+% Context reduction is the process of eliminating redundant constraints
+% from the constraints in the type_assign and adding the proof of the
+% constraint's redundancy to the proofs in the same type_assign. There
+% are two ways in which a constraint may be redundant:
+% - if there is an instance declaration that may be applied, the
+% constraint is replaced by the constraints from that instance
+% declaration
+% - if a constraint is present in the set of constraints and all
+% of the "superclass" constraints for the constraints are all
+% present, then all the superclass constraints are eliminated
+%
+% In addition, context reduction removes repeated constraints.
+%
+% If context reduction fails on a type_assign, that type_assign is
+% removed from the type_assign_set. Context reduction fails if there is
+% a constraint where the type of (at least) one of the arguments to
+% the constraint has its top level functor bound, but there is no
+% instance declaration for that type.
+%
+% If all type_assigns from the typecheck_info are rejected, than an
+% appropriate error message is given.
+
+:- pred perform_context_reduction(typecheck_info, typecheck_info).
+:- mode perform_context_reduction(typecheck_info_di, typecheck_info_uo) is det.
+
+perform_context_reduction(TypeCheckInfo0, TypeCheckInfo) :-
+ typecheck_info_get_module_info(TypeCheckInfo0, ModuleInfo),
+ module_info_classes(ModuleInfo, ClassTable),
+ module_info_instances(ModuleInfo, InstanceTable),
+ typecheck_info_get_type_assign_set(TypeCheckInfo0, TypeAssignSet0),
+ list__filter_map(reduce_type_assign_context(ClassTable, InstanceTable),
+ TypeAssignSet0, TypeAssignSet),
+ (
+ % Check that this context reduction hasn't eliminated
+ % all the type assignments.
+ TypeAssignSet = [],
+ TypeAssignSet0 \= []
+ ->
+ report_unsatisfied_constraints(TypeAssignSet0,
+ TypeCheckInfo0, TypeCheckInfo)
+ ;
+ typecheck_info_set_type_assign_set(TypeCheckInfo0,
+ TypeAssignSet, TypeCheckInfo)
+ ).
+
+ % XXX do we need to do this to fixpoint?
+:- pred reduce_type_assign_context(class_table, instance_table,
+ type_assign, type_assign).
+:- mode reduce_type_assign_context(in, in, in, out) is semidet.
+
+reduce_type_assign_context(ClassTable, InstanceTable,
+ TypeAssign0, TypeAssign) :-
+ type_assign_get_typeclass_constraints(TypeAssign0, Constraints0),
+ type_assign_get_type_bindings(TypeAssign0, Bindings),
+ type_assign_get_typevarset(TypeAssign0, Tvarset0),
+ type_assign_get_constraint_proofs(TypeAssign0, Proofs0),
+
+ typecheck__reduce_context_by_rule_application(InstanceTable,
+ ClassTable, Bindings, Tvarset0, Tvarset, Proofs0, Proofs,
+ Constraints0, Constraints),
+
+ type_assign_set_typeclass_constraints(TypeAssign0, Constraints,
+ TypeAssign1),
+ type_assign_set_typevarset(TypeAssign1, Tvarset, TypeAssign2),
+ type_assign_set_constraint_proofs(TypeAssign2, Proofs, TypeAssign).
+
+
+typecheck__reduce_context_by_rule_application(InstanceTable, ClassTable,
+ Bindings, Tvarset0, Tvarset, Proofs0, Proofs,
+ Constraints0, Constraints) :-
+ apply_instance_rules(Constraints0, InstanceTable, Bindings,
+ Tvarset0, Tvarset, Proofs0, Proofs1, Constraints1),
+ apply_class_rules(Constraints1, ClassTable, Bindings, Tvarset,
+ Proofs1, Proofs, Constraints2),
+ list__sort_and_remove_dups(Constraints2, Constraints).
+
+:- pred apply_instance_rules(list(class_constraint), instance_table,
+ tsubst, tvarset, tvarset, map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof), list(class_constraint)).
+:- mode apply_instance_rules(in, in, in, in, out, in, out, out) is semidet.
+
+apply_instance_rules([], _, _, Names, Names, Proofs, Proofs, []).
+apply_instance_rules([C|Cs], InstanceTable, Bindings,
+ TypeNames, NewTypeNames, Proofs0, Proofs, Constraints) :-
+ C = constraint(ClassName, Types0),
+ list__length(Types0, Arity),
+ map__lookup(InstanceTable, class_id(ClassName, Arity), Instances),
+ term__apply_rec_substitution_to_list(Types0, Bindings, Types),
+ (
+ find_matching_instance_rule(Instances, ClassName, Types,
+ TypeNames, NewTypeNames0, Proofs0, Proofs1,
+ NewConstraints0)
+ ->
+ % Put the new constraints at the front of the list
+ NewConstraints = NewConstraints0,
+ NewTypeNames1 = NewTypeNames0,
+ Proofs2 = Proofs1
+ ;
+ % Put the old constraint at the front of the list
+ NewConstraints = [C],
+ NewTypeNames1 = TypeNames,
+ Proofs2 = Proofs0
+ ),
+ apply_instance_rules(Cs, InstanceTable, Bindings, NewTypeNames1,
+ NewTypeNames, Proofs2, Proofs, TheRest),
+ 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, TypeNames,
+ NewTypeNames, Proofs0, Proofs, NewConstraints) :-
+
+ % Start a counter so we remember which instance decl we have
+ % used.
+ find_matching_instance_rule2(Instances, 1, ClassName, Types,
+ TypeNames, NewTypeNames, Proofs0, Proofs, NewConstraints).
+
+:- pred find_matching_instance_rule2(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_rule2(in, in, in, in, in, out, in, out, out)
+ is semidet.
+
+find_matching_instance_rule2([I|Is], N0, ClassName, Types, TypeNames,
+ NewTypeNames, Proofs0, Proofs, NewConstraints) :-
+ I = hlds_instance_defn(ModuleName, NewConstraints0, InstanceTypes0,
+ Interface, PredProcIds, InstanceNames, SuperClassProofs),
+ (
+ varset__merge_subst(TypeNames, InstanceNames, NewTypeNames0,
+ 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),
+ NewTypeNames = NewTypeNames0,
+ 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_rule2(Is, N, ClassName,
+ Types, TypeNames, NewTypeNames, 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)).
+:- mode apply_class_rules(in, in, in, in, in, out, out) is det.
+
+apply_class_rules(Constraints0, ClassTable, Bindings, TypeNames,
+ Proofs0, Proofs, Constraints) :-
+ apply_class_rules2(Constraints0, Constraints0, ClassTable, Bindings,
+ TypeNames, Proofs0, Proofs, Constraints).
+
+:- pred apply_class_rules2(list(class_constraint), list(class_constraint),
+ class_table, tsubst, tvarset, map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof), list(class_constraint)).
+:- mode apply_class_rules2(in, in, in, in, in, in, 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_rules2([], Constraints, _, _, _, Proofs, Proofs, Constraints).
+apply_class_rules2([C|Cs], AllConstraints, ClassTable, Bindings, TypeNames,
+ Proofs0, Proofs, Constraints) :-
+ C = constraint(ClassName, Types0),
+ list__length(Types0, Arity),
+ ClassId = class_id(ClassName, Arity),
+ map__lookup(ClassTable, ClassId, ClassDefn),
+ term__apply_rec_substitution_to_list(Types0, Bindings, Types),
+ ClassDefn = hlds_class_defn(ParentClassConstraints0, ClassVars,
+ _ClassInterface, ClassVarset),
+ term__var_list_to_term_list(ClassVars, ClassTypes),
+ % XXX Can we really ignore _NewTypeNames?
+ varset__merge_subst(TypeNames, ClassVarset, _NewTypeNames, 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),
+
+ apply_class_rules2(NewCs, NewConstraints, ClassTable, Bindings,
+ TypeNames, Proofs1, Proofs, Constraints).
+
+%-----------------------------------------------------------------------------%
+
+:- 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 +3302,14 @@
:- type type_assign ---> type_assign(
map(var, type), % var types
tvarset, % type names
- tsubst % type bindings
+ tsubst, % type bindings
+ list(class_constraint), % typeclass
+ % constraints
+ map(class_constraint, % for each
+ constraint_proof) % constraint
+ % found to be
+ % redundant,
+ % why is it so?
).
%-----------------------------------------------------------------------------%
@@ -2816,45 +3320,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)).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -2899,16 +3437,17 @@
{ 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) },
{ MaybeDet = no },
prog_out__write_context(Context),
io__write_string("Inferred "),
( { PredOrFunc = predicate },
mercury_output_pred_type(VarSet, Name, Types, MaybeDet,
- Context)
+ ClassContext, Context)
; { PredOrFunc = function },
{ pred_args_to_func_args(Types, ArgTypes, RetType) },
mercury_output_func_type(VarSet, Name, ArgTypes,
- RetType, MaybeDet, Context)
+ RetType, MaybeDet, ClassContext, Context)
).
%-----------------------------------------------------------------------------%
@@ -3417,7 +3956,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"),
@@ -3873,7 +4413,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.83
diff -u -r1.83 unify_gen.m
--- unify_gen.m 1997/09/01 14:05:29 1.83
+++ unify_gen.m 1997/09/08 04:13:25
@@ -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) :-
@@ -290,11 +293,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 = [] } ->
@@ -546,6 +559,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.40
diff -u -r1.40 unique_modes.m
--- unique_modes.m 1997/09/15 21:12:50 1.40
+++ unique_modes.m 1997/10/23 05:31:18
@@ -495,6 +495,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"),
+ % This 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.35
diff -u -r1.35 unused_args.m
--- unused_args.m 1997/09/01 14:05:44 1.35
+++ unused_args.m 1997/10/23 00:54:37
@@ -394,6 +394,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).
@@ -885,11 +889,15 @@
pred_info_clauses_info(PredInfo0, ClausesInfo),
pred_info_get_marker_list(PredInfo0, MarkerList),
pred_info_get_goal_type(PredInfo0, GoalType),
+ map__init(EmptyProofs),
% *** This will need to be fixed when the condition
% field of the pred_info becomes used.
+ % XXX
+ % XXX The class context shouldn't be empty!!!
+ % XXX
pred_info_init(PredModule, qualified(PredModule, Name), Arity, Tvars,
ArgTypes, true, Context, ClausesInfo, Status, MarkerList,
- GoalType, PredOrFunc, PredInfo1),
+ GoalType, PredOrFunc, [], EmptyProofs, PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVars, PredInfo).
@@ -1188,6 +1196,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.8
diff -u -r1.8 compiler_design.html
--- compiler_design.html 1997/11/08 13:12:08 1.8
+++ compiler_design.html 1997/11/17 02:39:48
@@ -125,8 +125,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 +135,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>
Index: library/mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.84
diff -u -r1.84 mercury_builtin.m
--- mercury_builtin.m 1997/10/14 09:27:19 1.84
+++ mercury_builtin.m 1997/11/20 07:51:34
@@ -229,10 +229,27 @@
% 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 /*, ... */).
+
+:- pred type_info_from_typeclass_info(typeclass_info, int, type_info(T)).
+:- mode type_info_from_typeclass_info(in, in, out) is det.
+
+:- 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 +269,21 @@
% Many of the predicates defined in this module are builtin -
% the compiler generates code for them inline.
+
+:- pragma c_code(will_not_call_mercury,
+ type_info_from_typeclass_info(TypeClassInfo::in, Index::in,
+ TypeInfo::out),
+"
+ TypeInfo = MR_typeclass_info_type_info(TypeClassInfo, Index);
+").
+
+:- pragma c_code(will_not_call_mercury,
+ superclass_from_typeclass_info(TypeClassInfo0::in, Index::in,
+ TypeClassInfo::out),
+"
+ 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.18
diff -u -r1.18 ops.m
--- ops.m 1997/07/27 15:07:00 1.18
+++ ops.m 1997/09/17 04:20:51
@@ -187,6 +187,7 @@
ops__op_table("import_sym", before, fx, 1199). % Mercury extension (NYI)
ops__op_table("import_type", before, fx, 1199). % Mercury extension (NYI)
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
@@ -201,6 +202,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.96
diff -u -r1.96 string.m
--- string.m 1997/10/11 16:11:25 1.96
+++ string.m 1997/10/14 07:01:20
@@ -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.1
diff -u -r1.1 mercury_ho_call.c
--- mercury_ho_call.c 1997/11/20 02:00:20 1.1
+++ mercury_ho_call.c 1997/11/21 00:02:42
@@ -96,6 +96,8 @@
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;
@@ -168,6 +170,8 @@
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;
@@ -225,6 +229,8 @@
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;
@@ -244,6 +250,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.1
diff -u -r1.1 mercury_type_info.h
--- mercury_type_info.h 1997/11/20 02:01:22 1.1
+++ mercury_type_info.h 1997/11/20 23:46:48
@@ -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