[m-rev.] for review: fix Mantus bug #44
Zoltan Somogyi
zs at csse.unimelb.edu.au
Fri Feb 8 21:56:03 AEDT 2008
This diff fixes the compiler abort, but I haven't had time to bootcheck it
yet. Note that there is no need to modify the MLDS backend equivalent
of unify_gen.m, since the MLDS has no equivalent of the negative stack slot
number that caused the abort.
For review by anyone, but I think Peter will want to look at the places
in ctgc.*.m where I added XXXs.
Zoltan.
---------------------------------------------------------------------------
Fix two problems that together caused bug Mantis bug #44.
The first bug was that unify_gen.m wasn't checking whether a variable it was
adding to a closure was of dummy type or not.
The second bug was that the code for recognizing whether a type is dummy or not
recognized only two cases: builtin dummy types such as io.state, and types
with one function symbol of arity zero. In this program, there is a notag
wrapper around a dummy type. Since the representation of a notag type is
always the same as the type it wraps, this notag type should be recognized
as a dummy type too.
compiler/unify_gen.m:
Fix the first bug by adding the required checks.
compiler/code_info.m:
Add a utility predicate to factor out some now common code in
unify_gen.m.
(The modifications to all the following files were to fix the second bug.)
compiler/hlds_data.m:
compiler/prog_type.m:
Change the type_category type (in prog_type.m) and the enum_or_dummy
type (in hlds_data.m) to separate out the representation of notag types
from other du types. This allows the fix for the second bug, and
incidentally allows some parts of the compiler to avoid the same tests
over and over.
To ensure that all places in the compiler that could need special
handling for notag types get them, rename those types to
type_ctor_category (since it does *not* take argument types into
account) and du_type_kind respectively.
Since the type_ctor_category type needs to be modified anyway,
change it to allow code that manipulates values of the type to
factor out common code fragments.
Rename some predicates, and turn some into functions where this helps
to make code (either here or in clients) more robust.
compiler/make_tags.m:
When creating a HLDS representation for a du type, record whether
it is a notag type (we already recorded whether it is enum or dummy).
compiler/type_util.m:
Fix the predicate that tests for dummy types by recognizing the third
way a type can be a dummy type.
Don't test for dummyness of the argument when deciding whether
a type could be a notag types; just record it as a notag type,
and let later lookup code use the new fixed algorithm to do the right
thing.
Add a type for recording the is_dummy_type/is_not_dummy_type
distinction.
Rename some predicates, and turn some into functions where this helps
to make code (either here or in clients) more robust.
Add an XXX about possible redundant code.
compiler/llds.m:
Use the new type instead of booleans in some places.
compiler/add_pragma.m:
compiler/add_special_pred.m:
compiler/add_type.m:
compiler/bytecode_gen.m:
compiler/continuation_info.m:
compiler/ctgc.selector.m:
compiler/ctgc.util.m:
compiler/equiv_type_hlds.m:
compiler/erl_call_gen.m:
compiler/erl_code_gen.m:
compiler/erl_code_util.m:
compiler/erl_unify_gen.m:
compiler/exception_analysis.m:
compiler/export.m:
compiler/foreign.m:
compiler/higher_order.m:
compiler/hlds_data.m:
compiler/hlds_out.m:
compiler/hlds_pred.m:
compiler/inst_match.m:
compiler/intermod.m:
compiler/llds_out.m:
compiler/ml_call_gen.m:
compiler/ml_closure_gen.m:
compiler/ml_code_gen.m:
compiler/ml_code_util.m:
compiler/ml_simplify_switch.m:
compiler/ml_switch_gen.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen.m:
compiler/mlds.m:
compiler/mlds_to_c.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
compiler/opt_debug.m:
compiler/opt_util.m:
compiler/polymorphism.m:
compiler/pragma_c_gen.m:
compiler/prog_type.m:
compiler/rtti_to_mlds.m:
compiler/simplify.m:
compiler/special_pred.m:
compiler/stack_layout.m:
compiler/switch_gen.m:
compiler/switch_util.m:
compiler/table_gen.m:
compiler/term_constr_util.m:
compiler/term_norm.m:
compiler/trace_gen.m:
compiler/trailing_analysis.m:
compiler/type_ctor_info.m:
compiler/type_util.m:
compiler/unify_proc.m:
compiler/var_locn.m:
Conform to the changes above.
Make a few analyses more precise by using the new detail in the
type_ctor_category type to make less conservative assumptions about
du types that are either notag or dummy.
In ctgc.selector.m, ctgc.util.m, make_tags.m, mlds_to_java.m
and special_pred.m, add XXXs about possible bugs.
tests/valid/fzn_debug_abort.m:
Add the bug demo program from Mantis as a regression test.
tests/valid/Mmakefile:
tests/valid/Mercury.options:
Enable the new test, and run it with the old bug-inducing option.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing boehm_gc/windows-untested
cvs diff: Diffing boehm_gc/windows-untested/vc60
cvs diff: Diffing boehm_gc/windows-untested/vc70
cvs diff: Diffing boehm_gc/windows-untested/vc71
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.79
diff -u -b -r1.79 add_pragma.m
--- compiler/add_pragma.m 29 Jan 2008 02:06:02 -0000 1.79
+++ compiler/add_pragma.m 8 Feb 2008 01:06:03 -0000
@@ -662,12 +662,12 @@
;
% XXX How should we handle IsForeignType here?
TypeBody = hlds_du_type(Ctors, _TagValues, _CheaperTagTest,
- IsEnumOrDummy, _MaybeUserEq, _ReservedTag, _ReservedAddr,
+ DuTypeKind, _MaybeUserEq, _ReservedTag, _ReservedAddr,
_IsForeignType),
(
- ( IsEnumOrDummy = is_mercury_enum
- ; IsEnumOrDummy = is_foreign_enum(_)
- ; IsEnumOrDummy = is_dummy
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
+ ; DuTypeKind = du_type_kind_direct_dummy
),
Attributes = export_enum_attributes(MaybePrefix),
(
@@ -689,21 +689,21 @@
TypeCtor, Mapping),
module_info_get_exported_enums(!.ModuleInfo,
ExportedEnums0),
- ExportedEnums = [ ExportedEnum | ExportedEnums0 ],
+ ExportedEnums = [ExportedEnum | ExportedEnums0],
module_info_set_exported_enums(ExportedEnums,
!ModuleInfo)
;
MaybeMapping = no
- ),
- ErrorPieces = [],
- MaybeSeverity = no
+ )
;
- MaybeOverridesMap = no,
+ MaybeOverridesMap = no
+ ),
ErrorPieces = [],
MaybeSeverity = no
- )
;
- IsEnumOrDummy = not_enum_or_dummy,
+ ( DuTypeKind = du_type_kind_general
+ ; DuTypeKind = du_type_kind_notag(_, _, _)
+ ),
MaybeSeverity = yes(severity_error),
% XXX Maybe we should add a verbose error message that
% identifies the non-zero arity constructors.
@@ -752,11 +752,9 @@
unexpected(this_file,
"unqualified type name while building override map")
),
- %
- % Strip off module qualifiers that match those of the type
- % being exported. We leave those that do not match so that
- % they can be reported as errors later.
- %
+ % Strip off module qualifiers that match those of the type being exported.
+ % We leave those that do not match so that they can be reported as errors
+ % later.
StripQualifiers = (func(Name0) = Name :-
(
Name0 = qualified(ModuleQualifier, UnqualName),
@@ -1010,19 +1008,17 @@
]
;
TypeBody0 = hlds_du_type(Ctors, OldTagValues, CheaperTagTest,
- IsEnumOrDummy0, MaybeUserEq, ReservedTag, ReservedAddr,
+ DuTypeKind0, MaybeUserEq, ReservedTag, ReservedAddr,
IsForeignType),
- %
% Work out what language's foreign_enum pragma we should be
% looking at for the the current compilation target language.
- %
module_info_get_globals(!.ModuleInfo, Globals),
globals.get_target(Globals, TargetLanguage),
LangForForeignEnums =
target_lang_to_foreign_enum_lang(TargetLanguage),
(
- ( IsEnumOrDummy0 = is_dummy
- ; IsEnumOrDummy0 = is_mercury_enum
+ ( DuTypeKind0 = du_type_kind_direct_dummy
+ ; DuTypeKind0 = du_type_kind_mercury_enum
),
get_type_defn_status(TypeDefn0, TypeStatus),
% Either both the type and the pragma are defined in this
@@ -1042,7 +1038,7 @@
->
% XXX We should also check that this type is not
% the subject of a reserved tag pragma.
- IsEnumOrDummy = is_foreign_enum(Lang),
+ DuTypeKind = du_type_kind_foreign_enum(Lang),
build_foreign_enum_tag_map(Context, ContextPieces,
TypeName, ForeignTagValues, MaybeForeignTagMap,
!Specs),
@@ -1056,7 +1052,7 @@
(
UnmappedCtors = [],
TypeBody = hlds_du_type(Ctors, TagValues,
- CheaperTagTest, IsEnumOrDummy, MaybeUserEq,
+ CheaperTagTest, DuTypeKind, MaybeUserEq,
ReservedTag, ReservedAddr, IsForeignType),
set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
svmap.set(TypeCtor, TypeDefn, TypeTable0,
@@ -1090,7 +1086,7 @@
]
)
;
- IsEnumOrDummy0 = is_foreign_enum(_),
+ DuTypeKind0 = du_type_kind_foreign_enum(_),
( LangForForeignEnums \= Lang ->
MaybeSeverity = no,
ErrorPieces = []
@@ -1103,7 +1099,9 @@
]
)
;
- IsEnumOrDummy0 = not_enum_or_dummy,
+ ( DuTypeKind0 = du_type_kind_general
+ ; DuTypeKind0 = du_type_kind_notag(_, _, _)
+ ),
MaybeSeverity = yes(severity_error),
ErrorPieces = [
words("error: "),
@@ -1185,7 +1183,7 @@
( match_sym_name(CtorModuleName, TypeModuleName) ->
CtorSymName = qualified(TypeModuleName, Name)
;
- !:BadCtors = [ CtorSymName0 | !.BadCtors],
+ !:BadCtors = [CtorSymName0 | !.BadCtors],
CtorSymName = CtorSymName0
)
),
@@ -3614,8 +3612,8 @@
inst_var_renaming::in, inst_var_renaming::out) is semidet.
match_corresponding_inst_lists_with_renaming(_, [], [], !Renaming).
-match_corresponding_inst_lists_with_renaming(ModuleInfo,
- [ A | As ], [ B | Bs ], !Renaming) :-
+match_corresponding_inst_lists_with_renaming(ModuleInfo, [A | As], [B | Bs],
+ !Renaming) :-
match_insts_with_renaming(ModuleInfo, A, B, Renaming0),
merge_inst_var_renamings(Renaming0, !Renaming),
match_corresponding_inst_lists_with_renaming(ModuleInfo, As, Bs,
@@ -3627,7 +3625,7 @@
match_corresponding_bound_inst_lists_with_renaming(_, [], [], !Renaming).
match_corresponding_bound_inst_lists_with_renaming(ModuleInfo,
- [A | As ], [B | Bs], !Renaming) :-
+ [A | As], [B | Bs], !Renaming) :-
A = bound_functor(ConsId, ArgsA),
B = bound_functor(ConsId, ArgsB),
match_corresponding_inst_lists_with_renaming(ModuleInfo, ArgsA, ArgsB,
Index: compiler/add_special_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_special_pred.m,v
retrieving revision 1.24
diff -u -b -r1.24 add_special_pred.m
--- compiler/add_special_pred.m 23 Nov 2007 07:34:53 -0000 1.24
+++ compiler/add_special_pred.m 7 Feb 2008 14:33:01 -0000
@@ -146,7 +146,7 @@
ThisModule = yes,
(
Ctors = Body ^ du_type_ctors,
- Body ^ du_type_is_enum = not_enum_or_dummy,
+ Body ^ du_type_kind = du_type_kind_general,
Body ^ du_type_usereq = no,
module_info_get_globals(!.ModuleInfo, Globals),
globals.lookup_int_option(Globals, compare_specialization,
Index: compiler/add_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_type.m,v
retrieving revision 1.31
diff -u -b -r1.31 add_type.m
--- compiler/add_type.m 30 Dec 2007 08:23:31 -0000 1.31
+++ compiler/add_type.m 8 Feb 2008 02:24:45 -0000
@@ -385,11 +385,13 @@
!:Specs = CtorAddSpecs ++ !.Specs
),
+ % XXX Why is this being done now, rather than *after* all the types
+ % have been added into the HLDS?
(
- type_with_constructors_should_be_no_tag(Globals, TypeCtor,
- ReservedTag, ConsList, UserEqCmp, Name, CtorArgType, _)
+ type_ctor_should_be_notag(Globals, TypeCtor,
+ ReservedTag, ConsList, UserEqCmp, CtorName, CtorArgType, _)
->
- NoTagType = no_tag_type(Args, Name, CtorArgType),
+ NoTagType = no_tag_type(Args, CtorName, CtorArgType),
module_info_get_no_tag_types(!.ModuleInfo, NoTagTypes0),
map.set(NoTagTypes0, TypeCtor, NoTagType, NoTagTypes),
module_info_set_no_tag_types(NoTagTypes, !ModuleInfo)
@@ -466,16 +468,16 @@
FoundError = yes
).
-:- pred merge_foreign_type_bodies(compilation_target::in, bool::in,
- hlds_type_body::in, hlds_type_body::in, hlds_type_body::out)
- is semidet.
-
% Ignore Mercury definitions if we've got a foreign type
% declaration suitable for this back-end and we aren't making the
% optimization interface. We need to keep the Mercury definition
% if we are making the optimization interface so that it gets
% output in the .opt file.
%
+:- pred merge_foreign_type_bodies(compilation_target::in, bool::in,
+ hlds_type_body::in, hlds_type_body::in, hlds_type_body::out)
+ is semidet.
+
merge_foreign_type_bodies(Target, MakeOptInterface,
hlds_foreign_type(ForeignTypeBody0), Body1, Body) :-
MaybeForeignTypeBody1 = Body1 ^ du_type_is_foreign_type,
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.117
diff -u -b -r1.117 bytecode_gen.m
--- compiler/bytecode_gen.m 30 Dec 2007 08:23:31 -0000 1.117
+++ compiler/bytecode_gen.m 8 Feb 2008 03:29:19 -0000
@@ -552,53 +552,44 @@
ByteInfo = byte_info(_, _, ModuleInfo, _, _),
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
(
- TypeCategory = type_cat_int,
+ TypeCategory = ctor_cat_builtin(cat_builtin_int),
TestId = int_test
;
- TypeCategory = type_cat_char,
+ TypeCategory = ctor_cat_builtin(cat_builtin_char),
TestId = char_test
;
- TypeCategory = type_cat_string,
+ TypeCategory = ctor_cat_builtin(cat_builtin_string),
TestId = string_test
;
- TypeCategory = type_cat_float,
+ TypeCategory = ctor_cat_builtin(cat_builtin_float),
TestId = float_test
;
- TypeCategory = type_cat_dummy,
+ TypeCategory = ctor_cat_builtin_dummy,
TestId = dummy_test
;
- TypeCategory = type_cat_enum,
+ TypeCategory = ctor_cat_enum(cat_enum_mercury),
TestId = enum_test
;
- TypeCategory = type_cat_foreign_enum,
+ TypeCategory = ctor_cat_enum(cat_enum_foreign),
sorry(this_file, "foreign enums with bytecode backend")
;
- TypeCategory = type_cat_higher_order,
+ TypeCategory = ctor_cat_higher_order,
unexpected(this_file, "higher_order_type in simple_test")
;
- TypeCategory = type_cat_tuple,
+ TypeCategory = ctor_cat_tuple,
unexpected(this_file, "tuple_type in simple_test")
;
- TypeCategory = type_cat_user_ctor,
+ TypeCategory = ctor_cat_user(_),
unexpected(this_file, "user_ctor_type in simple_test")
;
- TypeCategory = type_cat_variable,
+ TypeCategory = ctor_cat_variable,
unexpected(this_file, "variable_type in simple_test")
;
- TypeCategory = type_cat_void,
+ TypeCategory = ctor_cat_void,
unexpected(this_file, "void_type in simple_test")
;
- TypeCategory = type_cat_type_info,
- unexpected(this_file, "type_info_type in simple_test")
- ;
- TypeCategory = type_cat_type_ctor_info,
- unexpected(this_file, "type_ctor_info_type in simple_test")
- ;
- TypeCategory = type_cat_typeclass_info,
- unexpected(this_file, "typeclass_info_type in simple_test")
- ;
- TypeCategory = type_cat_base_typeclass_info,
- unexpected(this_file, "base_typeclass_info_type in simple_test")
+ TypeCategory = ctor_cat_system(_),
+ unexpected(this_file, "system type in simple_test")
),
Code = node([byte_test(ByteVar1, ByteVar2, TestId)]).
gen_unify(complicated_unify(_,_,_), _Var, _RHS, _ByteInfo, _Code) :-
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.358
diff -u -b -r1.358 code_info.m
--- compiler/code_info.m 29 Jan 2008 04:59:36 -0000 1.358
+++ compiler/code_info.m 8 Feb 2008 08:50:09 -0000
@@ -29,6 +29,7 @@
:- module ll_backend.code_info.
:- interface.
+:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
@@ -62,7 +63,6 @@
:- import_module backend_libs.builtin_ops.
:- import_module backend_libs.proc_label.
-:- import_module check_hlds.type_util.
:- import_module hlds.arg_info.
:- import_module hlds.hlds_code_util.
:- import_module hlds.hlds_rtti.
@@ -712,6 +712,8 @@
%
:- func variable_type(code_info, prog_var) = mer_type.
+:- func variable_is_of_dummy_type(code_info, prog_var) = is_dummy_type.
+
% Compute the principal type constructor of the given type, and return the
% definition of this type constructor, if it has one (some type
% constructors are built in, and some are hidden behind abstraction
@@ -903,6 +905,11 @@
variable_type(CI, Var) = Type :-
map.lookup(get_var_types(CI), Var, Type).
+variable_is_of_dummy_type(CI, Var) = IsDummy :-
+ VarType = variable_type(CI, Var),
+ get_module_info(CI, ModuleInfo),
+ IsDummy = check_dummy_type(ModuleInfo, VarType).
+
search_type_defn(CI, Type, TypeDefn) :-
get_module_info(CI, ModuleInfo),
type_to_ctor_and_args_det(Type, TypeCtor, _),
@@ -3891,9 +3898,7 @@
valid_stack_slot(ModuleInfo, VarTypes, Var - Lval) :-
map.lookup(VarTypes, Var, Type),
- ( is_dummy_argument_type(ModuleInfo, Type) ->
- fail
- ;
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type,
(
( Lval = stackvar(N)
; Lval = parent_stackvar(N)
@@ -3905,7 +3910,6 @@
"valid_stack_slot: nondummy var in dummy stack slot")
;
true
- )
).
:- pred setup_call_args(assoc_list(prog_var, arg_info)::in,
Index: compiler/continuation_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/continuation_info.m,v
retrieving revision 1.93
diff -u -b -r1.93 continuation_info.m
--- compiler/continuation_info.m 23 Nov 2007 07:34:58 -0000 1.93
+++ compiler/continuation_info.m 8 Feb 2008 06:40:42 -0000
@@ -693,7 +693,7 @@
VarTypes, ProcInfo, ModuleInfo, !VarInfos, !TVars) :-
(
map.lookup(VarTypes, Var, Type),
- is_dummy_argument_type(ModuleInfo, Type)
+ check_dummy_type(ModuleInfo, Type) = is_dummy_type
->
true
;
Index: compiler/ctgc.selector.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ctgc.selector.m,v
retrieving revision 1.8
diff -u -b -r1.8 ctgc.selector.m
--- compiler/ctgc.selector.m 17 Jan 2008 01:34:51 -0000 1.8
+++ compiler/ctgc.selector.m 8 Feb 2008 08:42:12 -0000
@@ -308,8 +308,10 @@
SelectorAcc0, !Selector) :-
(
!.Selector = [UnitSelector | SelRest],
- Class = classify_type(ModuleInfo, VarType),
- ( Class = type_cat_user_ctor ->
+ CtorCat = classify_type(ModuleInfo, VarType),
+ % XXX This test seems to be a bug: it shouldn't succeed for either
+ % notag types or dummy types.
+ ( CtorCat = ctor_cat_user(_) ->
% If it is either a term-selector of a non-existentially typed
% functor or is a type-selector, construct the branch map and
% proceed with normalization. If it is a term-selector of an
Index: compiler/ctgc.util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ctgc.util.m,v
retrieving revision 1.16
diff -u -b -r1.16 ctgc.util.m
--- compiler/ctgc.util.m 29 Jan 2008 03:03:33 -0000 1.16
+++ compiler/ctgc.util.m 8 Feb 2008 06:44:49 -0000
@@ -184,24 +184,26 @@
TypeCat = classify_type(ModuleInfo, Type),
type_category_is_reusable(TypeCat) = yes.
-:- func type_category_is_reusable(type_category) = bool.
+:- func type_category_is_reusable(type_ctor_category) = bool.
-type_category_is_reusable(type_cat_int) = no.
-type_category_is_reusable(type_cat_char) = no.
-type_category_is_reusable(type_cat_string) = no.
-type_category_is_reusable(type_cat_float) = no.
-type_category_is_reusable(type_cat_higher_order) = no.
-type_category_is_reusable(type_cat_tuple) = yes.
-type_category_is_reusable(type_cat_enum) = no.
-type_category_is_reusable(type_cat_foreign_enum) = no.
-type_category_is_reusable(type_cat_dummy) = no.
-type_category_is_reusable(type_cat_variable) = no.
-type_category_is_reusable(type_cat_type_info) = no.
-type_category_is_reusable(type_cat_type_ctor_info) = no.
-type_category_is_reusable(type_cat_typeclass_info) = no.
-type_category_is_reusable(type_cat_base_typeclass_info) = no.
-type_category_is_reusable(type_cat_void) = no.
-type_category_is_reusable(type_cat_user_ctor) = yes.
+type_category_is_reusable(CtorCat) = Reusable :-
+ (
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_system(_)
+ ),
+ Reusable = no
+ ;
+ % XXX I don't think notag user types should be reusable.
+ ( CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_user(_)
+ ),
+ Reusable = yes
+ ).
%-----------------------------------------------------------------------------%
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.48
diff -u -b -r1.48 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 22 Jan 2008 15:06:09 -0000 1.48
+++ compiler/equiv_type_hlds.m 8 Feb 2008 06:47:24 -0000
@@ -826,8 +826,7 @@
GoalExpr = GoalExpr0
).
replace_in_goal_expr(EqvMap, GoalExpr0 @ generic_call(A, B, Modes0, D),
-GoalExpr,
- Changed, !Info) :-
+ GoalExpr, Changed, !Info) :-
TVarSet0 = !.Info ^ tvarset,
Cache0 = !.Info ^ inst_cache,
replace_in_modes(EqvMap, Modes0, Modes, Changed, TVarSet0, TVarSet,
@@ -847,15 +846,15 @@
proc_info_get_vartypes(!.Info ^ proc_info, VarTypes),
proc_info_get_rtti_varmaps(!.Info ^ proc_info, RttiVarMaps),
map.lookup(VarTypes, Var, VarType),
- classify_type(!.Info ^ module_info, VarType) = TypeCat,
+ TypeCtorCat = classify_type(!.Info ^ module_info, VarType),
(
% If this goal constructs a type_info for an equivalence type,
% we need to expand that to make the type_info for the expanded type.
- % It's simpler to just recreate the type_info from scratch.
- %
+ % It is simpler to just recreate the type_info from scratch.
+
GoalExpr0 ^ unify_kind = construct(_, ConsId, _, _, _, _, _),
ConsId = type_info_cell_constructor(TypeCtor),
- TypeCat = type_cat_type_info,
+ TypeCtorCat = ctor_cat_system(cat_system_type_info),
map.search(Types, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
Body = hlds_eqv_type(_)
@@ -897,10 +896,10 @@
% Check for a type_ctor_info for an equivalence type. We can just
% remove these because after the code above to fix up type_infos
% for equivalence types they can't be used.
- %
+
GoalExpr0 ^ unify_kind = construct(_, ConsId, _, _, _, _, _),
ConsId = type_info_cell_constructor(TypeCtor),
- TypeCat = type_cat_type_ctor_info,
+ TypeCtorCat = ctor_cat_system(cat_system_type_ctor_info),
map.search(Types, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
Body = hlds_eqv_type(_)
Index: compiler/erl_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_call_gen.m,v
retrieving revision 1.14
diff -u -b -r1.14 erl_call_gen.m
--- compiler/erl_call_gen.m 24 Aug 2007 05:09:35 -0000 1.14
+++ compiler/erl_call_gen.m 8 Feb 2008 06:32:24 -0000
@@ -157,7 +157,7 @@
% The variable may not be in VarTypes if it did not exist in the
% HLDS, i.e. we invented the variable. Those should be kept.
map.search(VarTypes, Var, Type),
- is_dummy_argument_type(ModuleInfo, Type)
+ check_dummy_type(ModuleInfo, Type) = is_dummy_type
then
Expr = elds_term(elds_false)
else
@@ -286,7 +286,7 @@
assign_false_if_dummy(Info, Var, AssignFalse) :-
erl_gen_info_get_module_info(Info, ModuleInfo),
erl_variable_type(Info, Var, VarType),
- is_dummy_argument_type(ModuleInfo, VarType),
+ check_dummy_type(ModuleInfo, VarType) = is_dummy_type,
AssignFalse = var_eq_false(Var).
%-----------------------------------------------------------------------------%
@@ -376,9 +376,12 @@
ArgTypes = [_SrcType, DestType]
->
erl_gen_info_get_module_info(!.Info, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, DestType) ->
+ IsDummy = check_dummy_type(ModuleInfo, DestType),
+ (
+ IsDummy = is_dummy_type,
Statement = expr_or_void(MaybeSuccessExpr)
;
+ IsDummy = is_not_dummy_type,
erl_gen_info_get_var_types(!.Info, VarTypes),
SrcVarExpr = var_to_expr_or_false(ModuleInfo, VarTypes, SrcVar),
Assign = elds_eq(expr_from_var(DestVar), SrcVarExpr),
@@ -418,7 +421,7 @@
% We need to avoid generating assignments to dummy variables
% introduced for types such as io.state.
map.lookup(VarTypes, Lval, LvalType),
- is_dummy_argument_type(ModuleInfo, LvalType)
+ check_dummy_type(ModuleInfo, LvalType) = is_dummy_type
->
Statement = expr_or_void(MaybeSuccessExpr)
;
Index: compiler/erl_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_gen.m,v
retrieving revision 1.29
diff -u -b -r1.29 erl_code_gen.m
--- compiler/erl_code_gen.m 30 Dec 2007 08:23:37 -0000 1.29
+++ compiler/erl_code_gen.m 8 Feb 2008 06:34:54 -0000
@@ -235,7 +235,7 @@
in_in_unification_proc_id(ProcId),
list.reverse(Args, [Y, X | _]),
map.lookup(VarTypes, Y, Type),
- not is_dummy_argument_type(ModuleInfo, Type),
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type,
type_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type),
erl_gen_simple_in_in_unification(ModuleInfo, PredId, ProcId, X, Y,
ProcDefn)
@@ -243,7 +243,7 @@
SpecialId = spec_pred_compare,
list.reverse(Args, [Y, X, _Res | _]),
map.lookup(VarTypes, Y, Type),
- not is_dummy_argument_type(ModuleInfo, Type),
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type,
type_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type),
erl_gen_simple_compare(ModuleInfo, PredId, ProcId, X, Y, ProcDefn)
),
@@ -783,14 +783,14 @@
erl_variable_type(!.Info, Var, VarType),
erl_gen_info_get_module_info(!.Info, ModuleInfo),
- type_util.classify_type(ModuleInfo, VarType) = TypeCategory,
+ type_util.classify_type(ModuleInfo, VarType) = TypeCtorCategory,
(if
% The HiPE compiler is extremely slow compiling functions containing
% long case statements involving strings. Workaround: for a string
% switch with many cases, convert the string to an atom and switch on
% atoms instead.
- TypeCategory = type_cat_string,
+ TypeCtorCategory = ctor_cat_builtin(cat_builtin_string),
% list_to_atom could throw an exception for long strings, so we don't
% enable the workaround unless the user specifically passes
@@ -994,7 +994,7 @@
:- func non_dummy_var(module_info, prog_var, mer_type) = prog_var is semidet.
non_dummy_var(ModuleInfo, Var, Type) = Var :-
- not is_dummy_argument_type(ModuleInfo, Type).
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type.
:- pred ground_var_in_instmap(prog_var::in, instmap::in, instmap::out) is det.
Index: compiler/erl_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_util.m,v
retrieving revision 1.16
diff -u -b -r1.16 erl_code_util.m
--- compiler/erl_code_util.m 23 Nov 2007 07:35:00 -0000 1.16
+++ compiler/erl_code_util.m 8 Feb 2008 06:36:05 -0000
@@ -352,7 +352,7 @@
OptDummyArgs = opt_dummy_args,
% Exclude arguments of type io.state etc.
% Also exclude those with arg_mode `top_unused'.
- ( is_dummy_argument_type(ModuleInfo, ArgType)
+ ( check_dummy_type(ModuleInfo, ArgType) = is_dummy_type
; ArgMode = top_unused
)
->
@@ -409,7 +409,7 @@
is_bound_and_not_dummy(ModuleInfo, VarTypes, InstMap, InstmapDelta, Var) :-
var_is_bound_in_instmap_delta(ModuleInfo, InstMap, InstmapDelta, Var),
map.lookup(VarTypes, Var, Type),
- not is_dummy_argument_type(ModuleInfo, Type).
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type.
erl_bind_unbound_vars(Info, VarsToBind, Goal, InstMap,
Statement0, Statement) :-
@@ -525,7 +525,7 @@
erl_var_or_dummy_replacement(ModuleInfo, VarTypes, DummyVarReplacement, Var) =
(if
map.search(VarTypes, Var, Type),
- is_dummy_argument_type(ModuleInfo, Type)
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type
then
elds_term(DummyVarReplacement)
else
Index: compiler/erl_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_unify_gen.m,v
retrieving revision 1.11
diff -u -b -r1.11 erl_unify_gen.m
--- compiler/erl_unify_gen.m 17 Aug 2007 02:08:38 -0000 1.11
+++ compiler/erl_unify_gen.m 8 Feb 2008 06:48:45 -0000
@@ -100,9 +100,12 @@
Unification = assign(TargetVar, SourceVar),
erl_gen_info_get_module_info(!.Info, ModuleInfo),
erl_variable_type(!.Info, TargetVar, VarType),
- ( is_dummy_argument_type(ModuleInfo, VarType) ->
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
+ (
+ IsDummy = is_dummy_type,
Statement = expr_or_void(MaybeSuccessExpr)
;
+ IsDummy = is_not_dummy_type,
Assign = elds_eq(expr_from_var(TargetVar), expr_from_var(SourceVar)),
Statement = maybe_join_exprs(Assign, MaybeSuccessExpr)
).
@@ -138,9 +141,12 @@
),
erl_gen_info_get_module_info(!.Info, ModuleInfo),
erl_variable_type(!.Info, Var, VarType),
- ( is_dummy_argument_type(ModuleInfo, VarType) ->
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
+ (
+ IsDummy = is_dummy_type,
Statement = expr_or_void(MaybeSuccessExpr)
;
+ IsDummy = is_not_dummy_type,
erl_variable_types(!.Info, Args, ArgTypes),
erl_gen_construct(Var, ConsId, Args, ArgTypes, ArgModes, Context,
Construct, !Info),
@@ -198,7 +204,7 @@
UniMode = ((_LI - RI) -> (_LF - RF)),
not (
mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, top_in),
- not is_dummy_argument_type(ModuleInfo, ArgType)
+ check_dummy_type(ModuleInfo, ArgType) = is_not_dummy_type
% XXX ml_unify_gen also checks if ConsArgType is dummy type,
% do we need to do the same?
).
Index: compiler/exception_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exception_analysis.m,v
retrieving revision 1.42
diff -u -b -r1.42 exception_analysis.m
--- compiler/exception_analysis.m 30 Dec 2007 08:23:37 -0000 1.42
+++ compiler/exception_analysis.m 8 Feb 2008 06:54:30 -0000
@@ -862,65 +862,50 @@
Status = check_type_2(ModuleInfo, Type, TypeCategory)
).
-:- func check_type_2(module_info, mer_type, type_category) = type_status.
+:- func check_type_2(module_info, mer_type, type_ctor_category) = type_status.
-check_type_2(_, _, type_cat_int) = type_will_not_throw.
-check_type_2(_, _, type_cat_char) = type_will_not_throw.
-check_type_2(_, _, type_cat_string) = type_will_not_throw.
-check_type_2(_, _, type_cat_float) = type_will_not_throw.
-check_type_2(_, _, type_cat_higher_order) = type_will_not_throw.
-check_type_2(_, _, type_cat_type_info) = type_will_not_throw.
-check_type_2(_, _, type_cat_type_ctor_info) = type_will_not_throw.
-check_type_2(_, _, type_cat_typeclass_info) = type_will_not_throw.
-check_type_2(_, _, type_cat_base_typeclass_info) = type_will_not_throw.
-check_type_2(_, _, type_cat_void) = type_will_not_throw.
-check_type_2(_, _, type_cat_dummy) = type_will_not_throw.
-check_type_2(_, _, type_cat_variable) = type_conditional.
-check_type_2(ModuleInfo, Type, type_cat_tuple) = Status :-
+check_type_2(ModuleInfo, Type, CtorCat) = WillThrow :-
+ (
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_builtin_dummy
+ ),
+ WillThrow = type_will_not_throw
+ ;
+ CtorCat = ctor_cat_variable,
+ WillThrow = type_conditional
+ ;
+ CtorCat = ctor_cat_tuple,
( type_to_ctor_and_args(Type, _TypeCtor, Args) ->
- Status = check_types(ModuleInfo, Args)
+ WillThrow = check_types(ModuleInfo, Args)
;
unexpected(this_file, "check_type_2/3: expected tuple type")
- ).
-check_type_2(ModuleInfo, Type, type_cat_enum) =
- ( type_has_user_defined_equality_pred(ModuleInfo, Type, _UnifyCompare) ->
- % XXX This is very conservative.
- type_may_throw
+ )
;
- type_will_not_throw
- ).
-check_type_2(ModuleInfo, Type, type_cat_foreign_enum) =
- ( type_has_user_defined_equality_pred(ModuleInfo, Type, _UnifyCompare) ->
+ CtorCat = ctor_cat_enum(_),
+ ( type_has_user_defined_equality_pred(ModuleInfo, Type, _UC) ->
% XXX This is very conservative.
- type_may_throw
+ WillThrow = type_may_throw
;
- type_will_not_throw
- ).
-
-check_type_2(ModuleInfo, Type, type_cat_user_ctor) =
- check_user_type(ModuleInfo, Type).
-
-:- func check_user_type(module_info, mer_type) = type_status.
-
-check_user_type(ModuleInfo, Type) = Status :-
- ( type_to_ctor_and_args(Type, TypeCtor, Args) ->
- (
- type_has_user_defined_equality_pred(ModuleInfo, Type,
- _UnifyCompare)
- ->
+ WillThrow = type_will_not_throw
+ )
+ ;
+ CtorCat = ctor_cat_user(_),
+ type_to_ctor_and_args_det(Type, TypeCtor, Args),
+ ( type_has_user_defined_equality_pred(ModuleInfo, Type, _UC) ->
% XXX We can do better than this by examining what these preds
% actually do. Something similar needs to be sorted out for
% termination analysis as well, so we'll wait until that is done.
- Status = type_may_throw
+ WillThrow = type_may_throw
;
( type_ctor_is_safe(TypeCtor) ->
- Status = check_types(ModuleInfo, Args)
+ WillThrow = check_types(ModuleInfo, Args)
;
- Status = type_may_throw
+ WillThrow = type_may_throw
)
)
- ;
- unexpected(this_file, "Unable to get ctor and args.")
).
% Succeeds if the exception status of the type represented by the given
Index: compiler/export.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.119
diff -u -b -r1.119 export.m
--- compiler/export.m 30 Dec 2007 08:23:37 -0000 1.119
+++ compiler/export.m 8 Feb 2008 03:15:14 -0000
@@ -403,7 +403,7 @@
pred_args_to_func_args(ArgInfoTypes0, ArgInfoTypes1,
arg_info(RetArgLoc, RetArgMode) - RetType),
RetArgMode = top_out,
- \+ is_dummy_argument_type(ModuleInfo, RetType)
+ check_dummy_type(ModuleInfo, RetType) = is_not_dummy_type
->
Export_RetType = foreign.to_exported_type(ModuleInfo, RetType),
C_RetType = exported_type_to_string(lang_c, Export_RetType),
@@ -459,7 +459,7 @@
include_arg(ModuleInfo, arg_info(_Loc, Mode) - Type) :-
Mode \= top_unused,
- \+ is_dummy_argument_type(ModuleInfo, Type).
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type.
% get_argument_declarations(Args, NameThem, DeclString):
%
@@ -812,15 +812,17 @@
unexpected(this_file, "invalid type for foreign_export_enum")
;
TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest,
- IsEnumOrDummy, _MaybeUserEq, _ReservedTag, _ReservedAddr,
+ DuTypeKind, _MaybeUserEq, _ReservedTag, _ReservedAddr,
_IsForeignType),
(
- IsEnumOrDummy = not_enum_or_dummy,
+ ( DuTypeKind = du_type_kind_general
+ ; DuTypeKind = du_type_kind_notag(_, _, _)
+ ),
unexpected(this_file, "d.u. is not an enumeration.")
;
- ( IsEnumOrDummy = is_mercury_enum
- ; IsEnumOrDummy = is_foreign_enum(_)
- ; IsEnumOrDummy = is_dummy
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
+ ; DuTypeKind = du_type_kind_direct_dummy
),
list.foldl(foreign_const_name_and_tag(NameMapping, TagValues),
Ctors, [], ForeignNamesAndTags0),
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.77
diff -u -b -r1.77 foreign.m
--- compiler/foreign.m 30 Dec 2007 08:23:38 -0000 1.77
+++ compiler/foreign.m 8 Feb 2008 02:57:01 -0000
@@ -411,7 +411,7 @@
RetArg = pragma_var(_, RetArgName, RetMode, _) - RetType,
mode_to_arg_mode(!.ModuleInfo, RetMode, RetType, RetArgMode),
RetArgMode = top_out,
- \+ type_util.is_dummy_argument_type(!.ModuleInfo, RetType)
+ check_dummy_type(!.ModuleInfo, RetType) = is_not_dummy_type
->
C_Code0 = RetArgName ++ " = "
;
@@ -457,7 +457,7 @@
include_import_arg(ModuleInfo, pragma_var(_Var, _Name, Mode, _Box) - Type) :-
mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
ArgMode \= top_unused,
- \+ type_util.is_dummy_argument_type(ModuleInfo, Type).
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type.
% create_pragma_vars(Vars, Modes, ArgNum0, PragmaVars):
%
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.174
diff -u -b -r1.174 higher_order.m
--- compiler/higher_order.m 29 Jan 2008 04:59:38 -0000 1.174
+++ compiler/higher_order.m 8 Feb 2008 06:57:31 -0000
@@ -2057,7 +2057,7 @@
)
->
(
- is_dummy_argument_type(ModuleInfo, SpecialPredType)
+ check_dummy_type(ModuleInfo, SpecialPredType) = is_dummy_type
->
specialize_unify_or_compare_pred_for_dummy(MaybeResult, Goal,
!Info)
@@ -2321,61 +2321,26 @@
find_builtin_type_with_equivalent_compare(ModuleInfo, Type, EqvType,
NeedIntCast) :-
- TypeCategory = classify_type(ModuleInfo, Type),
+ CtorCat = classify_type(ModuleInfo, Type),
(
- ( TypeCategory = type_cat_int
- ; TypeCategory = type_cat_char
- ; TypeCategory = type_cat_string
- ; TypeCategory = type_cat_float
- ),
+ CtorCat = ctor_cat_builtin(_),
EqvType = Type,
NeedIntCast = no
;
- TypeCategory = type_cat_dummy,
- unexpected(this_file,
- "dummy type in find_builtin_type_with_equivalent_compare")
- ;
- TypeCategory = type_cat_void,
- unexpected(this_file,
- "void type in find_builtin_type_with_equivalent_compare")
- ;
- TypeCategory = type_cat_higher_order,
- unexpected(this_file, "higher_order type in " ++
- "find_builtin_type_with_equivalent_compare")
- ;
- TypeCategory = type_cat_tuple,
- unexpected(this_file,
- "tuple type in find_builtin_type_with_equivalent_compare")
- ;
- ( TypeCategory = type_cat_enum
- ; TypeCategory = type_cat_foreign_enum
- ),
+ CtorCat = ctor_cat_enum(_),
construct_type(type_ctor(unqualified("int"), 0), [], EqvType),
NeedIntCast = yes
;
- TypeCategory = type_cat_variable,
- unexpected(this_file,
- "var type in find_builtin_type_with_equivalent_compare")
- ;
- TypeCategory = type_cat_user_ctor,
+ ( CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_system(_)
+ ),
unexpected(this_file,
- "user type in find_builtin_type_with_equivalent_compare")
- ;
- TypeCategory = type_cat_type_info,
- unexpected(this_file, "type_info type in " ++
- "find_builtin_type_with_equivalent_compare")
- ;
- TypeCategory = type_cat_type_ctor_info,
- unexpected(this_file, "type_ctor_info type in " ++
- "find_builtin_type_with_equivalent_compare")
- ;
- TypeCategory = type_cat_typeclass_info,
- unexpected(this_file, "typeclass_info type in " ++
- "find_builtin_type_with_equivalent_compare")
- ;
- TypeCategory = type_cat_base_typeclass_info,
- unexpected(this_file, "base_typeclass_info type in " ++
- "find_builtin_type_with_equivalent_compare")
+ "find_builtin_type_with_equivalent_compare: bad type")
).
:- pred generate_unsafe_type_cast(prog_context::in,
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.120
diff -u -b -r1.120 hlds_data.m
--- compiler/hlds_data.m 30 Dec 2007 08:23:41 -0000 1.120
+++ compiler/hlds_data.m 8 Feb 2008 01:29:48 -0000
@@ -167,10 +167,10 @@
% Their tag values.
du_type_cons_tag_values :: cons_tag_values,
- du_type_chaper_tag_test :: maybe_cheaper_tag_test,
+ du_type_cheaper_tag_test :: maybe_cheaper_tag_test,
- % Is this type an enumeration?
- du_type_is_enum :: enum_or_dummy,
+ % Is this type an enumeration or a dummy type?
+ du_type_kind :: du_type_kind,
% User-defined equality and comparison preds.
du_type_usereq :: maybe(unify_compare),
@@ -199,11 +199,20 @@
less_expensive_cons_tag :: cons_tag
).
-:- type enum_or_dummy
- ---> is_mercury_enum
- ; is_foreign_enum(foreign_language)
- ; is_dummy
- ; not_enum_or_dummy.
+:- type du_type_kind
+ ---> du_type_kind_mercury_enum
+ ; du_type_kind_foreign_enum(
+ dtkfe_language :: foreign_language
+ )
+ ; du_type_kind_direct_dummy
+ ; du_type_kind_notag(
+ % A notag type is a dummy type if and only if the type it wraps
+ % is a dummy type.
+ dtkn_functor_name :: sym_name,
+ dtkn_arg_type :: mer_type,
+ dtkn_maybe_arg_name :: maybe(string)
+ )
+ ; du_type_kind_general.
:- type foreign_type_body
---> foreign_type_body(
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.442
diff -u -b -r1.442 hlds_out.m
--- compiler/hlds_out.m 22 Jan 2008 15:06:10 -0000 1.442
+++ compiler/hlds_out.m 8 Feb 2008 01:06:03 -0000
@@ -3369,8 +3369,9 @@
:- pred write_type_body(int::in, tvarset::in, hlds_type_body::in,
io::di, io::uo) is det.
-write_type_body(Indent, TVarSet, DuType, !IO) :-
- DuType = hlds_du_type(Ctors, ConsTagMap, CheaperTagTest, EnumDummy,
+write_type_body(Indent, TVarSet, TypeBody, !IO) :-
+ (
+ TypeBody = hlds_du_type(Ctors, ConsTagMap, CheaperTagTest, DuTypeKind,
MaybeUserEqComp, ReservedTag, ReservedAddr, Foreign),
io.write_string(" --->\n", !IO),
(
@@ -3389,21 +3390,38 @@
io.write_string(" */\n", !IO)
),
(
- EnumDummy = is_mercury_enum,
+ DuTypeKind = du_type_kind_mercury_enum,
write_indent(Indent, !IO),
- io.write_string("/* enumeration */\n", !IO)
+ io.write_string("/* KIND enumeration */\n", !IO)
;
- EnumDummy = is_foreign_enum(Lang),
+ DuTypeKind = du_type_kind_foreign_enum(Lang),
write_indent(Indent, !IO),
- io.write_string("/* foreign enumeration for ", !IO),
+ io.write_string("/* KIND foreign enumeration for ", !IO),
io.write_string(foreign_language_string(Lang), !IO),
io.write_string(" */\n", !IO)
;
- EnumDummy = is_dummy,
+ DuTypeKind = du_type_kind_direct_dummy,
+ write_indent(Indent, !IO),
+ io.write_string("/* KIND dummy */\n", !IO)
+ ;
+ DuTypeKind = du_type_kind_notag(FunctorName, ArgType, MaybeArgName),
write_indent(Indent, !IO),
- io.write_string("/* dummy */\n", !IO)
+ io.write_string("/* KIND notag: ", !IO),
+ write_sym_name(FunctorName, !IO),
+ io.write_string(", ", !IO),
+ mercury_output_type(TVarSet, no, ArgType, !IO),
+ io.write_string(", ", !IO),
+ (
+ MaybeArgName = yes(ArgName),
+ io.write_string(ArgName, !IO)
+ ;
+ MaybeArgName = no,
+ io.write_string("no arg name", !IO)
+ ),
+ io.write_string(" */\n", !IO)
;
- EnumDummy = not_enum_or_dummy
+ DuTypeKind = du_type_kind_general,
+ io.write_string("/* KIND general */\n", !IO)
),
(
ReservedTag = uses_reserved_tag,
@@ -3428,25 +3446,25 @@
;
Foreign = no
),
- io.write_string(".\n", !IO).
-
-write_type_body(_Indent, TVarSet, hlds_eqv_type(Type), !IO) :-
+ io.write_string(".\n", !IO)
+ ;
+ TypeBody = hlds_eqv_type(Type),
io.write_string(" == ", !IO),
mercury_output_type(TVarSet, no, Type, !IO),
- io.write_string(".\n", !IO).
-
-write_type_body(_Indent, _TVarSet, hlds_abstract_type(_IsSolverType), !IO) :-
- io.write_string(".\n", !IO).
-
-write_type_body(_Indent, _TVarSet, hlds_foreign_type(_), !IO) :-
+ io.write_string(".\n", !IO)
+ ;
+ TypeBody = hlds_abstract_type(_IsSolverType),
+ io.write_string(".\n", !IO)
+ ;
+ TypeBody = hlds_foreign_type(_),
% XXX
- io.write_string(" == $foreign_type.\n", !IO).
-
-write_type_body(_Indent, TVarSet,
- hlds_solver_type(SolverTypeDetails, MaybeUserEqComp), !IO) :-
+ io.write_string(" == $foreign_type.\n", !IO)
+ ;
+ TypeBody = hlds_solver_type(SolverTypeDetails, MaybeUserEqComp),
mercury_output_where_attributes(TVarSet, yes(SolverTypeDetails),
MaybeUserEqComp, !IO),
- io.write_string(".\n", !IO).
+ io.write_string(".\n", !IO)
+ ).
:- pred write_constructors(int::in, tvarset::in,
list(constructor)::in, cons_tag_values::in, io::di, io::uo) is det.
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.236
diff -u -b -r1.236 hlds_pred.m
--- compiler/hlds_pred.m 10 Jan 2008 04:29:52 -0000 1.236
+++ compiler/hlds_pred.m 8 Feb 2008 06:57:56 -0000
@@ -2903,7 +2903,7 @@
var_is_of_dummy_type(ModuleInfo, VarTypes, Var) :-
map.lookup(VarTypes, Var, Type),
- is_dummy_argument_type(ModuleInfo, Type).
+ check_dummy_type(ModuleInfo, Type) = is_dummy_type.
%-----------------------------------------------------------------------------%
Index: compiler/inst_match.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.84
diff -u -b -r1.84 inst_match.m
--- compiler/inst_match.m 22 Jan 2008 15:06:11 -0000 1.84
+++ compiler/inst_match.m 8 Feb 2008 03:33:30 -0000
@@ -2050,24 +2050,27 @@
type_may_contain_solver_type(ModuleInfo, Type) :-
type_may_contain_solver_type_2(classify_type(ModuleInfo, Type)) = yes.
-:- func type_may_contain_solver_type_2(type_category) = bool.
+:- func type_may_contain_solver_type_2(type_ctor_category) = bool.
-type_may_contain_solver_type_2(type_cat_int) = no.
-type_may_contain_solver_type_2(type_cat_char) = no.
-type_may_contain_solver_type_2(type_cat_string) = no.
-type_may_contain_solver_type_2(type_cat_float) = no.
-type_may_contain_solver_type_2(type_cat_higher_order) = no.
-type_may_contain_solver_type_2(type_cat_tuple) = yes.
-type_may_contain_solver_type_2(type_cat_enum) = no.
-type_may_contain_solver_type_2(type_cat_foreign_enum) = no.
-type_may_contain_solver_type_2(type_cat_dummy) = no.
-type_may_contain_solver_type_2(type_cat_variable) = yes.
-type_may_contain_solver_type_2(type_cat_type_info) = no.
-type_may_contain_solver_type_2(type_cat_type_ctor_info) = no.
-type_may_contain_solver_type_2(type_cat_typeclass_info) = no.
-type_may_contain_solver_type_2(type_cat_base_typeclass_info) = no.
-type_may_contain_solver_type_2(type_cat_void) = no.
-type_may_contain_solver_type_2(type_cat_user_ctor) = yes.
+type_may_contain_solver_type_2(CtorCat) = MayContainSolverType :-
+ (
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_user(cat_user_direct_dummy)
+ ),
+ MayContainSolverType = no
+ ;
+ ( CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_user(cat_user_notag)
+ ; CtorCat = ctor_cat_user(cat_user_general)
+ ),
+ MayContainSolverType = yes
+ ).
%-----------------------------------------------------------------------------%
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.227
diff -u -b -r1.227 intermod.m
--- compiler/intermod.m 22 Jan 2008 15:06:11 -0000 1.227
+++ compiler/intermod.m 8 Feb 2008 06:58:10 -0000
@@ -415,7 +415,7 @@
(
mode_is_input(ModuleInfo, ArgMode),
map.lookup(VarTypes, HeadVar, Type),
- classify_type(ModuleInfo, Type) = type_cat_higher_order
+ classify_type(ModuleInfo, Type) = ctor_cat_higher_order
;
check_for_ho_input_args(ModuleInfo, VarTypes, HeadVars, ArgModes)
).
@@ -1363,8 +1363,8 @@
true
),
(
- Body = hlds_du_type(_, ConsTagVals, _, EnumOrDummy, _, _, _, _),
- EnumOrDummy = is_foreign_enum(Lang)
+ Body = hlds_du_type(_, ConsTagVals, _, DuTypeKind, _, _, _, _),
+ DuTypeKind = du_type_kind_foreign_enum(Lang)
->
map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [],
ForeignEnumVals),
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.358
diff -u -b -r1.358 llds.m
--- compiler/llds.m 23 Jan 2008 11:44:46 -0000 1.358
+++ compiler/llds.m 8 Feb 2008 08:17:08 -0000
@@ -20,6 +20,7 @@
:- import_module backend_libs.builtin_ops.
:- import_module backend_libs.rtti.
+:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_llds.
@@ -687,7 +688,7 @@
in_var_type :: mer_type,
% Whether in_var_type is a dummy type.
- in_var_type_is_dummy :: bool,
+ in_var_type_is_dummy :: is_dummy_type,
% The type of the argument in original foreign_proc procedure.
% If the foreign_proc was inlined in some other procedure,
@@ -717,7 +718,7 @@
out_var_type :: mer_type,
% Whether out_var_type is a dummy type.
- out_var_type_is_dummy :: bool,
+ out_var_type_is_dummy :: is_dummy_type,
% The type of the argument in original foreign_proc procedure;
% see in_original_type above.
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.323
diff -u -b -r1.323 llds_out.m
--- compiler/llds_out.m 23 Jan 2008 11:44:46 -0000 1.323
+++ compiler/llds_out.m 8 Feb 2008 08:38:39 -0000
@@ -180,6 +180,7 @@
:- import_module backend_libs.name_mangle.
:- import_module backend_libs.proc_label.
:- import_module backend_libs.rtti.
+:- import_module check_hlds.type_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module libs.compiler_util.
@@ -2877,20 +2878,21 @@
Input = foreign_proc_input(VarName, VarType, IsDummy, _OrigType, _Rval,
_MaybeForeignTypeInfo, _BoxPolicy),
(
- IsDummy = yes,
+ IsDummy = is_dummy_type,
(
% Avoid outputting an assignment for builtin dummy types.
% For other dummy types we must output an assignment because
% code in the foreign_proc body may examine the value.
type_to_ctor_and_args(VarType, VarTypeCtor, []),
- is_builtin_dummy_argument_type(VarTypeCtor)
+ check_builtin_dummy_type_ctor(VarTypeCtor) =
+ is_builtin_dummy_type_ctor
->
true
;
io.write_string("\t" ++ VarName ++ " = 0;\n", !IO)
)
;
- IsDummy = no,
+ IsDummy = is_not_dummy_type,
output_foreign_proc_input(Input, !IO)
),
output_foreign_proc_inputs(Inputs, !IO).
@@ -2981,9 +2983,9 @@
Output = foreign_proc_output(_Lval, _VarType, IsDummy, _OrigType, _VarName,
_MaybeForeignType, _BoxPolicy),
(
- IsDummy = yes
+ IsDummy = is_dummy_type
;
- IsDummy = no,
+ IsDummy = is_not_dummy_type,
output_foreign_proc_output(Output, !IO)
),
output_foreign_proc_outputs(Outputs, !IO).
Index: compiler/make_tags.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_tags.m,v
retrieving revision 1.58
diff -u -b -r1.58 make_tags.m
--- compiler/make_tags.m 25 Sep 2007 04:56:39 -0000 1.58
+++ compiler/make_tags.m 8 Feb 2008 02:52:36 -0000
@@ -78,7 +78,7 @@
:- pred assign_constructor_tags(list(constructor)::in,
maybe(unify_compare)::in, type_ctor::in, uses_reserved_tag::in,
globals::in, cons_tag_values::out,
- uses_reserved_address::out, enum_or_dummy::out) is det.
+ uses_reserved_address::out, du_type_kind::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -99,7 +99,7 @@
%-----------------------------------------------------------------------------%
assign_constructor_tags(Ctors, UserEqCmp, TypeCtor, ReservedTagPragma, Globals,
- CtorTags, ReservedAddr, EnumDummy) :-
+ CtorTags, ReservedAddr, DuTypeKind) :-
% Work out how many tag bits and reserved addresses we've got to play with.
globals.lookup_int_option(Globals, num_tag_bits, NumTagBits),
@@ -129,26 +129,29 @@
ReservedTagPragma = does_not_use_reserved_tag
->
( Ctors = [_] ->
- EnumDummy = is_dummy
+ DuTypeKind = du_type_kind_direct_dummy
;
- EnumDummy = is_mercury_enum
+ DuTypeKind = du_type_kind_mercury_enum
),
assign_enum_constants(Ctors, InitTag, CtorTags0, CtorTags),
ReservedAddr = does_not_use_reserved_address
;
- EnumDummy = not_enum_or_dummy,
(
% Try representing it as a no-tag type.
- type_with_constructors_should_be_no_tag(Globals, TypeCtor,
- ReservedTagPragma, Ctors, UserEqCmp, SingleFunc, SingleArg, _)
+ type_ctor_should_be_notag(Globals, TypeCtor, ReservedTagPragma,
+ Ctors, UserEqCmp, SingleFunctorName, SingleArgType,
+ MaybeSingleArgName)
->
- SingleConsId = make_cons_id_from_qualified_sym_name(SingleFunc,
- [SingleArg]),
+ SingleConsId = make_cons_id_from_qualified_sym_name(
+ SingleFunctorName, [SingleArgType]),
map.set(CtorTags0, SingleConsId, no_tag, CtorTags),
- ReservedAddr = does_not_use_reserved_address
+ % XXX What if SingleArgType uses reserved addresses?
+ ReservedAddr = does_not_use_reserved_address,
+ DuTypeKind = du_type_kind_notag(SingleFunctorName, SingleArgType,
+ MaybeSingleArgName)
;
- NumTagBits = 0
- ->
+ DuTypeKind = du_type_kind_general,
+ ( NumTagBits = 0 ->
(
ReservedTagPragma = uses_reserved_tag,
% XXX Need to fix this.
@@ -159,8 +162,9 @@
),
% Assign reserved addresses to the constants, if possible.
separate_out_constants(Ctors, Constants, Functors),
- assign_reserved_numeric_addresses(Constants, LeftOverConstants0,
- CtorTags0, CtorTags1, 0, NumReservedAddresses,
+ assign_reserved_numeric_addresses(Constants,
+ LeftOverConstants0, CtorTags0, CtorTags1,
+ 0, NumReservedAddresses,
does_not_use_reserved_address, ReservedAddr1),
(
HighLevelCode = yes,
@@ -193,6 +197,7 @@
CtorTags1, CtorTags),
ReservedAddr = does_not_use_reserved_address
)
+ )
).
:- pred assign_enum_constants(list(constructor)::in, int::in,
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.81
diff -u -b -r1.81 ml_call_gen.m
--- compiler/ml_call_gen.m 21 Jan 2008 00:32:50 -0000 1.81
+++ compiler/ml_call_gen.m 8 Feb 2008 07:03:22 -0000
@@ -315,9 +315,12 @@
ArgTypes = [SrcType, DestType]
->
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, DestType) ->
+ IsDummy = check_dummy_type(ModuleInfo, DestType),
+ (
+ IsDummy = is_dummy_type,
Statements = []
;
+ IsDummy = is_not_dummy_type,
ml_gen_box_or_unbox_rval(SrcType, DestType, native_if_possible,
lval(SrcLval), CastRval, !Info),
Assign = ml_gen_assign(DestLval, CastRval, Context),
@@ -647,23 +650,28 @@
!:OutputTypes, !:ConvDecls, !:ConvOutputStatements, !Info),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
mode_to_arg_mode(ModuleInfo, Mode, CalleeType, ArgMode),
- ( is_dummy_argument_type(ModuleInfo, CalleeType) ->
+ CalleeIsDummy = check_dummy_type(ModuleInfo, CalleeType),
+ (
+ CalleeIsDummy = is_dummy_type
% Exclude arguments of type io.state etc.
- true
;
+ CalleeIsDummy = is_not_dummy_type,
(
ArgMode = top_unused
% Also exclude those with arg_mode `top_unused'.
;
ArgMode = top_in,
% It's an input argument.
- ( is_dummy_argument_type(ModuleInfo, CallerType) ->
+ CallerIsDummy = check_dummy_type(ModuleInfo, CallerType),
+ (
+ CallerIsDummy = is_dummy_type,
% The variable may not have been declared, so we need to
% generate a dummy value for it. Using `0' here is more
% efficient than using private_builtin.dummy_var, which is
% what ml_gen_var will have generated for this variable.
VarRval = const(mlconst_int(0))
;
+ CallerIsDummy = is_not_dummy_type,
VarRval = lval(VarLval)
),
ml_gen_box_or_unbox_rval(CallerType, CalleeType,
@@ -856,12 +864,15 @@
ml_gen_var_lval(!.Info, ArgVarName, MLDS_CalleeType, ArgLval),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, CallerType) ->
+ CallerIsDummy = check_dummy_type(ModuleInfo, CallerType),
+ (
+ CallerIsDummy = is_dummy_type,
% If it is a dummy argument type (e.g. io.state),
% then we don't need to bother assigning it.
ConvInputStatements = [],
ConvOutputStatements = []
;
+ CallerIsDummy = is_not_dummy_type,
% Generate statements to box/unbox the fresh variable and assign it
% to/from the output argument whose address we were passed.
@@ -912,7 +923,7 @@
% introduced for types such as io.state.
Lval = var(_VarName, VarType),
VarType = mercury_type(ProgDataType, _, _),
- is_dummy_argument_type(ModuleInfo, ProgDataType)
+ check_dummy_type(ModuleInfo, ProgDataType) = is_dummy_type
->
Statements = []
;
Index: compiler/ml_closure_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_closure_gen.m,v
retrieving revision 1.55
diff -u -b -r1.55 ml_closure_gen.m
--- compiler/ml_closure_gen.m 21 Jan 2008 00:32:50 -0000 1.55
+++ compiler/ml_closure_gen.m 8 Feb 2008 07:03:00 -0000
@@ -1037,6 +1037,7 @@
% Handle output variables.
ml_gen_info_get_globals(!.Info, Globals),
CopyOut = get_copy_out_option(Globals, CodeModel),
+ IsDummy = check_dummy_type(ModuleInfo, Type),
(
(
CopyOut = yes
@@ -1047,16 +1048,18 @@
CodeModel = model_det,
ArgMode = top_out,
TypesTail = [],
- \+ type_util.is_dummy_argument_type(ModuleInfo, Type)
+ IsDummy = is_not_dummy_type
)
->
% Output arguments are copied out, so we need to generate
% a local declaration for them here.
Lval = VarLval,
- ( is_dummy_argument_type(ModuleInfo, Type) ->
+ (
+ IsDummy = is_dummy_type,
CopyOutLvals = CopyOutLvalsTail,
Defns = DefnsTail
;
+ IsDummy = is_not_dummy_type,
CopyOutLvals = [Lval | CopyOutLvalsTail],
ml_gen_local_for_output_arg(Name, Type,
ArgNum, Context, Defn, !Info),
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.210
diff -u -b -r1.210 ml_code_gen.m
--- compiler/ml_code_gen.m 21 Jan 2008 00:32:50 -0000 1.210
+++ compiler/ml_code_gen.m 8 Feb 2008 07:12:38 -0000
@@ -1520,10 +1520,13 @@
!Info) :-
map.lookup(VarTypes, Var, Type),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, Type) ->
- % no declaration needed for this variable
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
+ % No declaration needed for this variable.
ml_gen_local_var_decls(VarSet, VarTypes, Context, Vars, Defns, !Info)
;
+ IsDummy = is_not_dummy_type,
VarName = ml_gen_var_name(VarSet, Var),
ml_gen_var_decl(VarName, Type, Context, Defn, !Info),
ml_gen_local_var_decls(VarSet, VarTypes, Context, Vars, Defns0, !Info),
@@ -2111,10 +2114,13 @@
!Info),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
ml_variable_type(!.Info, Var, Type),
- ( is_dummy_argument_type(ModuleInfo, Type) ->
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
LocalDefns = LocalDefns0,
Assigns = Assigns0
;
+ IsDummy = is_not_dummy_type,
ml_gen_make_local_for_output_arg(Var, Type, Context,
LocalDefn, Assign, !Info),
LocalDefns = [LocalDefn | LocalDefns0],
@@ -2705,8 +2711,8 @@
),
(
MaybeVarMode = yes(ArgName - Mode),
- \+ is_dummy_argument_type(ModuleInfo, OrigType),
- \+ var_is_singleton(ArgName)
+ check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
+ not var_is_singleton(ArgName)
->
mode_to_arg_mode(ModuleInfo, Mode, OrigType, ArgMode),
(
@@ -2812,7 +2818,7 @@
VarSet, Context, IsByRef, Var, Statement) :-
map.lookup(ArgMap, Var, ForeignArg),
ForeignArg = foreign_arg(_, MaybeNameMode, Type, BoxPolicy),
- not is_dummy_argument_type(ModuleInfo, Type),
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type,
(
BoxPolicy = always_boxed,
MLDSType = mlds_generic_type
@@ -2865,7 +2871,7 @@
% Dummy arguments are just mapped to integers, since they shouldn't be
% used in any way that requires them to have a real value.
- ( is_dummy_argument_type(ModuleInfo, Type) ->
+ ( check_dummy_type(ModuleInfo, Type) = is_dummy_type ->
Initializer = no_initializer,
MLDSType = mlds_native_int_type
; list.member(Var, ByRefOutputVars) ->
@@ -3140,7 +3146,7 @@
ml_gen_info_get_module_info(Info, ModuleInfo),
(
MaybeNameAndMode = yes(ArgName - _Mode),
- \+ var_is_singleton(ArgName)
+ not var_is_singleton(ArgName)
->
(
BoxPolicy = always_boxed,
@@ -3200,7 +3206,7 @@
(
ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
MaybeNameAndMode = yes(ArgName - Mode),
- \+ var_is_singleton(ArgName),
+ not var_is_singleton(ArgName),
mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_in)
->
ml_gen_pragma_c_gen_input_arg(Lang, Var, ArgName, OrigType,
@@ -3220,13 +3226,16 @@
ml_variable_type(!.Info, Var, VarType),
ml_gen_var(!.Info, Var, VarLval),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, VarType) ->
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
+ (
+ IsDummy = is_dummy_type,
% The variable may not have been declared, so we need to generate
% a dummy value for it. Using `0' here is more efficient than using
% private_builtin.dummy_var, which is what ml_gen_var will have
% generated for this variable.
ArgRval = const(mlconst_int(0))
;
+ IsDummy = is_not_dummy_type,
ml_gen_box_or_unbox_rval(VarType, OrigType, BoxPolicy,
lval(VarLval), ArgRval, !Info)
),
@@ -3326,7 +3335,7 @@
(
MaybeNameAndMode = yes(ArgName - Mode),
not var_is_singleton(ArgName),
- not is_dummy_argument_type(ModuleInfo, OrigType),
+ check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_out)
->
% Create a target lval with the right type for *internal* use in the
@@ -3394,8 +3403,8 @@
ml_gen_info_get_module_info(!.Info, ModuleInfo),
(
MaybeNameAndMode = yes(ArgName - Mode),
- \+ var_is_singleton(ArgName),
- \+ is_dummy_argument_type(ModuleInfo, OrigType),
+ not var_is_singleton(ArgName),
+ check_dummy_type(ModuleInfo, OrigType) = is_not_dummy_type,
mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_out)
->
ml_gen_pragma_c_gen_output_arg(Lang, Var, ArgName, OrigType, BoxPolicy,
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.133
diff -u -b -r1.133 ml_code_util.m
--- compiler/ml_code_util.m 29 Jan 2008 04:59:40 -0000 1.133
+++ compiler/ml_code_util.m 8 Feb 2008 07:15:30 -0000
@@ -995,7 +995,8 @@
ml_gen_array_elem_type(elem_type_generic) = mlds_generic_type.
ml_string_type =
- mercury_type(string_type, type_cat_string, non_foreign_type(string_type)).
+ mercury_type(string_type, ctor_cat_builtin(cat_builtin_string),
+ non_foreign_type(string_type)).
ml_make_boxed_types(Arity) = BoxedTypes :-
varset.init(TypeVarSet0),
@@ -1100,7 +1101,7 @@
pred_args_to_func_args(HeadModes, _, ResultMode),
ResultMode = top_out,
pred_args_to_func_args(HeadTypes, _, ResultType),
- \+ is_dummy_argument_type(ModuleInfo, ResultType)
+ check_dummy_type(ModuleInfo, ResultType) = is_not_dummy_type
->
pred_args_to_func_args(FuncArgs0, FuncArgs, RetArg),
RetArg = mlds_argument(_RetArgName, RetTypePtr, _GCStatement),
@@ -1187,7 +1188,7 @@
(
% Exclude types such as io.state, etc.
% Also exclude values with arg_mode `top_unused'.
- ( is_dummy_argument_type(ModuleInfo, Type)
+ ( check_dummy_type(ModuleInfo, Type) = is_dummy_type
; Mode = top_unused
)
->
@@ -1258,7 +1259,7 @@
pred_args_to_func_args(ArgVars, _InputArgVars, RetArgVar),
RetArgMode = top_out,
- \+ is_dummy_argument_type(ModuleInfo, RetArgType).
+ check_dummy_type(ModuleInfo, RetArgType) = is_not_dummy_type.
%-----------------------------------------------------------------------------%
%
@@ -1431,7 +1432,9 @@
ml_gen_var_with_type(Info, Var, Type, Lval) :-
ml_gen_info_get_module_info(Info, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, Type) ->
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
% The variable won't have been declared, so we need to generate
% a dummy lval for this variable.
@@ -1441,6 +1444,7 @@
Lval = var(qual(MLDS_Module, module_qual,
mlds_var_name("dummy_var", no)), MLDS_Type)
;
+ IsDummy = is_not_dummy_type,
ml_gen_info_get_varset(Info, VarSet),
VarName = ml_gen_var_name(VarSet, Var),
ml_gen_type(Info, Type, MLDS_Type),
@@ -1592,24 +1596,28 @@
classify_type(ModuleInfo, Type) = Category,
ml_must_box_field_type_category(Category) = yes.
-:- func ml_must_box_field_type_category(type_category) = bool.
+:- func ml_must_box_field_type_category(type_ctor_category) = bool.
-ml_must_box_field_type_category(type_cat_int) = no.
-ml_must_box_field_type_category(type_cat_char) = yes.
-ml_must_box_field_type_category(type_cat_string) = no.
-ml_must_box_field_type_category(type_cat_float) = yes.
-ml_must_box_field_type_category(type_cat_higher_order) = no.
-ml_must_box_field_type_category(type_cat_tuple) = no.
-ml_must_box_field_type_category(type_cat_enum) = no.
-ml_must_box_field_type_category(type_cat_foreign_enum) = no.
-ml_must_box_field_type_category(type_cat_dummy) = no.
-ml_must_box_field_type_category(type_cat_variable) = no.
-ml_must_box_field_type_category(type_cat_type_info) = no.
-ml_must_box_field_type_category(type_cat_type_ctor_info) = no.
-ml_must_box_field_type_category(type_cat_typeclass_info) = no.
-ml_must_box_field_type_category(type_cat_base_typeclass_info) = no.
-ml_must_box_field_type_category(type_cat_void) = no.
-ml_must_box_field_type_category(type_cat_user_ctor) = no.
+ml_must_box_field_type_category(CtorCat) = MustBox :-
+ (
+ ( CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_string)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_user(_)
+ ),
+ MustBox = no
+ ;
+ ( CtorCat = ctor_cat_builtin(cat_builtin_char)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_float)
+ ),
+ MustBox = yes
+ ).
%-----------------------------------------------------------------------------%
%
@@ -1728,10 +1736,13 @@
ml_skip_dummy_argument_types([Type | Types0], [Var | Vars0], ModuleInfo,
Types, Vars) :-
ml_skip_dummy_argument_types(Types0, Vars0, ModuleInfo, Types1, Vars1),
- ( is_dummy_argument_type(ModuleInfo, Type) ->
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
Types = Types1,
Vars = Vars1
;
+ IsDummy = is_not_dummy_type,
Types = [Type | Types1],
Vars = [Var | Vars1]
).
@@ -1991,24 +2002,33 @@
ml_type_might_contain_pointers_for_gc(mlds_tabling_type(_)) = no.
ml_type_might_contain_pointers_for_gc(mlds_unknown_type) = yes.
-:- func ml_type_category_might_contain_pointers(type_category) = bool.
+:- func ml_type_category_might_contain_pointers(type_ctor_category) = bool.
-ml_type_category_might_contain_pointers(type_cat_int) = no.
-ml_type_category_might_contain_pointers(type_cat_char) = no.
-ml_type_category_might_contain_pointers(type_cat_string) = yes.
-ml_type_category_might_contain_pointers(type_cat_float) = no.
-ml_type_category_might_contain_pointers(type_cat_void) = no.
-ml_type_category_might_contain_pointers(type_cat_type_info) = yes.
-ml_type_category_might_contain_pointers(type_cat_type_ctor_info) = no.
-ml_type_category_might_contain_pointers(type_cat_typeclass_info) = yes.
-ml_type_category_might_contain_pointers(type_cat_base_typeclass_info) = no.
-ml_type_category_might_contain_pointers(type_cat_higher_order) = yes.
-ml_type_category_might_contain_pointers(type_cat_tuple) = yes.
-ml_type_category_might_contain_pointers(type_cat_enum) = no.
-ml_type_category_might_contain_pointers(type_cat_foreign_enum) = no.
-ml_type_category_might_contain_pointers(type_cat_dummy) = no.
-ml_type_category_might_contain_pointers(type_cat_variable) = yes.
-ml_type_category_might_contain_pointers(type_cat_user_ctor) = yes.
+ml_type_category_might_contain_pointers(CtorCat) = MayContainPointers :-
+ (
+ ( CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_char)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_float)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_system(cat_system_type_ctor_info)
+ ; CtorCat = ctor_cat_system(cat_system_base_typeclass_info)
+ ; CtorCat = ctor_cat_user(cat_user_direct_dummy)
+ ),
+ MayContainPointers = no
+ ;
+ ( CtorCat = ctor_cat_builtin(cat_builtin_string)
+ ; CtorCat = ctor_cat_system(cat_system_type_info)
+ ; CtorCat = ctor_cat_system(cat_system_typeclass_info)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_user(cat_user_notag)
+ ; CtorCat = ctor_cat_user(cat_user_general)
+ ),
+ MayContainPointers = yes
+ ).
% trace_type_info_type(Type, RealType):
%
@@ -2121,8 +2141,8 @@
MLDS_Module = mercury_module_name_to_mlds(PredModule),
ProcLabel = mlds_proc_label(PredLabel, ProcId),
QualProcLabel = qual(MLDS_Module, module_qual, ProcLabel),
- CPointerType = mercury_type(c_pointer_type, type_cat_user_ctor,
- non_foreign_type(c_pointer_type)),
+ CPointerType = mercury_type(c_pointer_type,
+ ctor_cat_user(cat_user_general), non_foreign_type(c_pointer_type)),
ArgTypes = [mlds_pseudo_type_info_type, CPointerType],
Signature = mlds_func_signature(ArgTypes, []),
FuncAddr = const(mlconst_code_addr(
Index: compiler/ml_simplify_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_simplify_switch.m,v
retrieving revision 1.25
diff -u -b -r1.25 ml_simplify_switch.m
--- compiler/ml_simplify_switch.m 21 Jan 2008 00:32:51 -0000 1.25
+++ compiler/ml_simplify_switch.m 8 Feb 2008 04:16:09 -0000
@@ -117,43 +117,61 @@
:- func is_integral_type(mlds_type) = bool.
-is_integral_type(mlds_mercury_array_type(_)) = no.
-is_integral_type(mlds_cont_type(_)) = no.
-is_integral_type(mlds_commit_type) = no.
-is_integral_type(mlds_native_bool_type) = no.
-is_integral_type(mlds_native_int_type) = yes.
-is_integral_type(mlds_native_char_type) = yes.
-is_integral_type(mlds_native_float_type) = no.
-is_integral_type(mercury_type(_, type_cat_int, _)) = yes.
-is_integral_type(mercury_type(_, type_cat_char, _)) = yes.
-is_integral_type(mercury_type(_, type_cat_string, _)) = no.
-is_integral_type(mercury_type(_, type_cat_float, _)) = no.
-is_integral_type(mercury_type(_, type_cat_higher_order, _)) = no.
-is_integral_type(mercury_type(_, type_cat_tuple, _)) = no.
-is_integral_type(mercury_type(_, type_cat_enum, _)) = yes.
-% XXX we are able to switch on foreign enumerations in C; this
-% may not be the case for the other target languages.
-is_integral_type(mercury_type(_, type_cat_foreign_enum, _)) = yes.
-is_integral_type(mercury_type(_, type_cat_dummy, _)) = no.
-is_integral_type(mercury_type(_, type_cat_variable, _)) = no.
-is_integral_type(mercury_type(_, type_cat_type_info, _)) = no.
-is_integral_type(mercury_type(_, type_cat_type_ctor_info, _)) = no.
-is_integral_type(mercury_type(_, type_cat_typeclass_info, _)) = no.
-is_integral_type(mercury_type(_, type_cat_base_typeclass_info, _)) = no.
-is_integral_type(mercury_type(_, type_cat_void, _)) = no.
-is_integral_type(mercury_type(_, type_cat_user_ctor, _)) = no.
-is_integral_type(mlds_foreign_type(_)) = no.
-is_integral_type(mlds_class_type(_, _, _)) = no.
-is_integral_type(mlds_ptr_type(_)) = no.
-is_integral_type(mlds_func_type(_)) = no.
-is_integral_type(mlds_type_info_type) = no.
-is_integral_type(mlds_generic_type) = no.
-is_integral_type(mlds_generic_env_ptr_type) = no.
-is_integral_type(mlds_array_type(_)) = no.
-is_integral_type(mlds_pseudo_type_info_type) = no.
-is_integral_type(mlds_rtti_type(_)) = no.
-is_integral_type(mlds_tabling_type(_)) = no.
-is_integral_type(mlds_unknown_type) = no.
+is_integral_type(MLDSType) = IsIntegral :-
+ (
+ ( MLDSType = mlds_native_int_type
+ ; MLDSType = mlds_native_char_type
+ ),
+ IsIntegral = yes
+ ;
+ ( MLDSType = mlds_mercury_array_type(_)
+ ; MLDSType = mlds_cont_type(_)
+ ; MLDSType = mlds_commit_type
+ ; MLDSType = mlds_native_bool_type
+ ; MLDSType = mlds_native_float_type
+ ; MLDSType = mlds_foreign_type(_)
+ ; MLDSType = mlds_class_type(_, _, _)
+ ; MLDSType = mlds_ptr_type(_)
+ ; MLDSType = mlds_func_type(_)
+ ; MLDSType = mlds_type_info_type
+ ; MLDSType = mlds_generic_type
+ ; MLDSType = mlds_generic_env_ptr_type
+ ; MLDSType = mlds_array_type(_)
+ ; MLDSType = mlds_pseudo_type_info_type
+ ; MLDSType = mlds_rtti_type(_)
+ ; MLDSType = mlds_tabling_type(_)
+ ; MLDSType = mlds_unknown_type
+ ),
+ IsIntegral = no
+ ;
+ MLDSType = mercury_type(_, CtorCat, _),
+ (
+ ( CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_char)
+ ; CtorCat = ctor_cat_enum(cat_enum_mercury)
+ ),
+ IsIntegral = yes
+ ;
+ ( CtorCat = ctor_cat_builtin(cat_builtin_string)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_float)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_user(cat_user_notag)
+ ; CtorCat = ctor_cat_user(cat_user_general)
+ ; CtorCat = ctor_cat_user(cat_user_direct_dummy)
+ ),
+ IsIntegral = no
+ ;
+ CtorCat = ctor_cat_enum(cat_enum_foreign),
+ % XXX We can switch on foreign enumerations in C, but this may
+ % not be the case for the other target languages.
+ IsIntegral = no
+ )
+ ).
:- pred is_dense_switch(list(mlds_switch_case)::in, int::in) is semidet.
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.36
diff -u -b -r1.36 ml_switch_gen.m
--- compiler/ml_switch_gen.m 31 Dec 2007 08:13:30 -0000 1.36
+++ compiler/ml_switch_gen.m 8 Feb 2008 07:16:00 -0000
@@ -326,8 +326,8 @@
determine_category(Info, CaseVar) = SwitchCategory :-
ml_variable_type(Info, CaseVar, Type),
ml_gen_info_get_module_info(Info, ModuleInfo),
- type_util.classify_type(ModuleInfo, Type) = TypeCategory,
- SwitchCategory = switch_util.type_cat_to_switch_cat(TypeCategory).
+ type_util.classify_type(ModuleInfo, Type) = TypeCtorCategory,
+ SwitchCategory = switch_util.type_ctor_cat_to_switch_cat(TypeCtorCategory).
%-----------------------------------------------------------------------------%
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.74
diff -u -b -r1.74 ml_type_gen.m
--- compiler/ml_type_gen.m 21 Jan 2008 00:32:52 -0000 1.74
+++ compiler/ml_type_gen.m 8 Feb 2008 01:06:03 -0000
@@ -158,24 +158,26 @@
% see our BABEL'01 paper "Compiling Mercury to the .NET CLR".
% The same issue arises for some of the cases below.
;
- TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, EnumDummy,
+ TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, DuTypeKind,
MaybeUserEqComp, _ReservedTag, _, _),
% XXX We probably shouldn't ignore _ReservedTag.
ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers),
(
- ( EnumDummy = is_mercury_enum
- ; EnumDummy = is_foreign_enum(_)
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
),
ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues,
MaybeEqualityMembers, !Defns)
;
- EnumDummy = is_dummy,
+ DuTypeKind = du_type_kind_direct_dummy,
% XXX We shouldn't have to generate an MLDS type for these types,
% but it is not easy to ensure that we never refer to that type.
ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues,
MaybeEqualityMembers, !Defns)
;
- EnumDummy = not_enum_or_dummy,
+ ( DuTypeKind = du_type_kind_notag(_, _, _)
+ ; DuTypeKind = du_type_kind_general
+ ),
ml_gen_du_parent_type(ModuleInfo, TypeCtor, TypeDefn,
Ctors, TagValues, MaybeEqualityMembers, !Defns)
)
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.123
diff -u -b -r1.123 ml_unify_gen.m
--- compiler/ml_unify_gen.m 4 Feb 2008 03:56:18 -0000 1.123
+++ compiler/ml_unify_gen.m 8 Feb 2008 07:22:56 -0000
@@ -126,7 +126,7 @@
% Skip dummy argument types, since they will not have been declared.
ml_variable_type(!.Info, TargetVar, Type),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
- is_dummy_argument_type(ModuleInfo, Type)
+ check_dummy_type(ModuleInfo, Type) = is_dummy_type
->
Statements = []
;
@@ -872,12 +872,8 @@
% Check for type_infos and typeclass_infos,
% since these need to be handled specially;
% their Mercury type definitions are lies.
- MLDS_Type = mercury_type(_, TypeCategory, _),
- ( TypeCategory = type_cat_type_info
- ; TypeCategory = type_cat_type_ctor_info
- ; TypeCategory = type_cat_typeclass_info
- ; TypeCategory = type_cat_base_typeclass_info
- )
+ MLDS_Type = mercury_type(_, TypeCtorCategory, _),
+ TypeCtorCategory = ctor_cat_system(_)
->
ConstType = mlds_array_type(mlds_generic_type)
;
@@ -891,7 +887,7 @@
(
MLDS_Type = mlds_class_type(QualTypeName, TypeArity, _)
;
- MLDS_Type = mercury_type(MercuryType, type_cat_user_ctor, _),
+ MLDS_Type = mercury_type(MercuryType, ctor_cat_user(_), _),
type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes),
ml_gen_type_name(TypeCtor, QualTypeName, TypeArity)
)
@@ -912,7 +908,7 @@
% mapped to `mlds_ptr_type(mlds_class_type(...))', but when
% declarating static constants we want just the class type,
% not the pointer type.
- MLDS_Type = mercury_type(MercuryType, type_cat_user_ctor, _),
+ MLDS_Type = mercury_type(MercuryType, ctor_cat_user(_), _),
type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes)
->
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
@@ -920,7 +916,7 @@
;
% For tuples, a similar issue arises; we want tuple constants
% to have array type, not the pointer type MR_Tuple.
- MLDS_Type = mercury_type(_, type_cat_tuple, _)
+ MLDS_Type = mercury_type(_, ctor_cat_tuple, _)
->
ConstType = mlds_array_type(mlds_generic_type)
;
@@ -928,7 +924,7 @@
% the pointer type MR_ClosurePtr. Note that we use a low-level
% data representation for closures, even when --high-level-data
% is enabled.
- MLDS_Type = mercury_type(_, type_cat_higher_order, _)
+ MLDS_Type = mercury_type(_, ctor_cat_higher_order, _)
->
ConstType = mlds_array_type(mlds_generic_type)
;
@@ -1309,8 +1305,8 @@
;
(
mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, top_in),
- not is_dummy_argument_type(ModuleInfo, ArgType),
- not is_dummy_argument_type(ModuleInfo, ConsArgType)
+ check_dummy_type(ModuleInfo, ArgType) = is_not_dummy_type,
+ check_dummy_type(ModuleInfo, ConsArgType) = is_not_dummy_type
->
ml_gen_box_or_unbox_rval(ArgType, BoxedArgType, native_if_possible,
lval(Lval), Rval, !Info)
@@ -1684,8 +1680,8 @@
mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, RightMode),
(
% Skip dummy argument types, since they will not have been declared.
- ( is_dummy_argument_type(ModuleInfo, ArgType)
- ; is_dummy_argument_type(ModuleInfo, FieldType)
+ ( check_dummy_type(ModuleInfo, ArgType) = is_dummy_type
+ ; check_dummy_type(ModuleInfo, FieldType) = is_dummy_type
)
->
true
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.162
diff -u -b -r1.162 mlds.m
--- compiler/mlds.m 18 Jan 2008 05:26:33 -0000 1.162
+++ compiler/mlds.m 8 Feb 2008 03:11:22 -0000
@@ -708,7 +708,7 @@
% Mercury data types
mer_type, % The exact Mercury type.
- type_category, % What kind of type it is: enum, float, ...
+ type_ctor_category, % What kind of type it is: enum, float, ...
exported_type % A representation of the type which can be
% used to determine the foreign language
% representation of the type.
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.228
diff -u -b -r1.228 mlds_to_c.m
--- compiler/mlds_to_c.m 31 Dec 2007 10:03:49 -0000 1.228
+++ compiler/mlds_to_c.m 8 Feb 2008 07:24:39 -0000
@@ -1396,7 +1396,7 @@
Kind \= mlds_enum,
ClassType = Type
;
- Type = mercury_type(MercuryType, type_cat_user_ctor, _),
+ Type = mercury_type(MercuryType, ctor_cat_user(_), _),
type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes),
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
ClassType = mlds_class_type(ClassName, ClassArity, mlds_class)
@@ -2184,7 +2184,7 @@
HighLevelData = yes,
mlds_output_mercury_user_type_name(
type_ctor(qualified(unqualified("array"), "array"), 1),
- type_cat_user_ctor, !IO)
+ ctor_cat_user(cat_user_general), !IO)
;
HighLevelData = no,
io.write_string("MR_ArrayPtr", !IO)
@@ -2279,53 +2279,33 @@
mlds_output_type_prefix(mlds_unknown_type, !IO) :-
unexpected(this_file, "prefix has unknown type").
-:- pred mlds_output_mercury_type_prefix(mer_type::in, type_category::in,
+:- pred mlds_output_mercury_type_prefix(mer_type::in, type_ctor_category::in,
io::di, io::uo) is det.
-mlds_output_mercury_type_prefix(Type, TypeCategory, !IO) :-
+mlds_output_mercury_type_prefix(Type, CtorCat, !IO) :-
(
- TypeCategory = type_cat_char,
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
io.write_string("MR_Char", !IO)
;
- TypeCategory = type_cat_int,
+ CtorCat = ctor_cat_builtin(cat_builtin_int),
io.write_string("MR_Integer", !IO)
;
- TypeCategory = type_cat_string,
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
io.write_string("MR_String", !IO)
;
- TypeCategory = type_cat_float,
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
io.write_string("MR_Float", !IO)
;
- TypeCategory = type_cat_void,
+ CtorCat = ctor_cat_void,
io.write_string("MR_Word", !IO)
;
- TypeCategory = type_cat_variable,
+ CtorCat = ctor_cat_variable,
io.write_string("MR_Box", !IO)
;
- TypeCategory = type_cat_type_info,
- % runtime/mercury_hlc_types requires typeclass_infos
- % to be treated as user defined types.
- mlds_output_mercury_user_type_prefix(Type, type_cat_user_ctor, !IO)
- ;
- TypeCategory = type_cat_type_ctor_info,
- % runtime/mercury_hlc_types requires typeclass_infos
- % to be treated as user defined types.
- mlds_output_mercury_user_type_prefix(Type, type_cat_user_ctor, !IO)
- ;
- TypeCategory = type_cat_typeclass_info,
- % runtime/mercury_hlc_types requires typeclass_infos
- % to be treated as user defined types.
- mlds_output_mercury_user_type_prefix(Type, type_cat_user_ctor, !IO)
- ;
- TypeCategory = type_cat_base_typeclass_info,
- % runtime/mercury_hlc_types requires typeclass_infos
- % to be treated as user defined types.
- mlds_output_mercury_user_type_prefix(Type, type_cat_user_ctor, !IO)
- ;
- TypeCategory = type_cat_tuple,
+ CtorCat = ctor_cat_tuple,
io.write_string("MR_Tuple", !IO)
;
- TypeCategory = type_cat_higher_order,
+ CtorCat = ctor_cat_higher_order,
globals.io_lookup_bool_option(highlevel_data, HighLevelData, !IO),
(
HighLevelData = yes,
@@ -2335,23 +2315,25 @@
io.write_string("MR_Word", !IO)
)
;
- ( TypeCategory = type_cat_enum
- ; TypeCategory = type_cat_dummy
- ; TypeCategory = type_cat_foreign_enum
- ; TypeCategory = type_cat_user_ctor
+ % runtime/mercury_hlc_types requires typeinfos, typeclass_infos etc
+ % to be treated as user defined types.
+ ( CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_system(_)
),
- mlds_output_mercury_user_type_prefix(Type, TypeCategory, !IO)
+ mlds_output_mercury_user_type_prefix(Type, CtorCat, !IO)
).
:- pred mlds_output_mercury_user_type_prefix(mer_type::in,
- type_category::in, io::di, io::uo) is det.
+ type_ctor_category::in, io::di, io::uo) is det.
-mlds_output_mercury_user_type_prefix(Type, TypeCategory, !IO) :-
+mlds_output_mercury_user_type_prefix(Type, CtorCat, !IO) :-
globals.io_lookup_bool_option(highlevel_data, HighLevelData, !IO),
(
HighLevelData = yes,
( type_to_ctor_and_args(Type, TypeCtor, _ArgsTypes) ->
- mlds_output_mercury_user_type_name(TypeCtor, TypeCategory, !IO)
+ mlds_output_mercury_user_type_name(TypeCtor, CtorCat, !IO)
;
unexpected(this_file, "mlds_output_mercury_user_type_prefix")
)
@@ -2361,31 +2343,23 @@
io.write_string("MR_Word", !IO)
).
-:- pred mlds_output_mercury_user_type_name(type_ctor::in, type_category::in,
- io::di, io::uo) is det.
+:- pred mlds_output_mercury_user_type_name(type_ctor::in,
+ type_ctor_category::in, io::di, io::uo) is det.
-mlds_output_mercury_user_type_name(TypeCtor, TypeCategory, !IO) :-
+mlds_output_mercury_user_type_name(TypeCtor, CtorCat, !IO) :-
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
(
- ( TypeCategory = type_cat_enum
- ; TypeCategory = type_cat_foreign_enum
- ),
+ CtorCat = ctor_cat_enum(_),
MLDS_Type = mlds_class_type(ClassName, ClassArity, mlds_enum)
;
- ( TypeCategory = type_cat_int
- ; TypeCategory = type_cat_char
- ; TypeCategory = type_cat_string
- ; TypeCategory = type_cat_float
- ; TypeCategory = type_cat_higher_order
- ; TypeCategory = type_cat_tuple
- ; TypeCategory = type_cat_dummy
- ; TypeCategory = type_cat_variable
- ; TypeCategory = type_cat_type_info
- ; TypeCategory = type_cat_type_ctor_info
- ; TypeCategory = type_cat_typeclass_info
- ; TypeCategory = type_cat_base_typeclass_info
- ; TypeCategory = type_cat_void
- ; TypeCategory = type_cat_user_ctor
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_user(_)
),
MLDS_Type = mlds_ptr_type(
mlds_class_type(ClassName, ClassArity, mlds_class))
@@ -3676,7 +3650,7 @@
mlds_output_boxed_rval(Type, Exprn, !IO) :-
(
( Type = mlds_generic_type
- ; Type = mercury_type(_, type_cat_variable, _)
+ ; Type = mercury_type(_, ctor_cat_variable, _)
)
->
% It already has type MR_Box, so no cast is needed.
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.137
diff -u -b -r1.137 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 31 Dec 2007 10:03:50 -0000 1.137
+++ compiler/mlds_to_gcc.m 8 Feb 2008 07:28:07 -0000
@@ -1858,34 +1858,36 @@
build_type(mlds_unknown_type, _, _, _) -->
{ unexpected(this_file, "build_type: unknown type") }.
-:- pred build_mercury_type(mer_type, type_category, gcc__type,
+:- pred build_mercury_type(mer_type, type_ctor_category, gcc__type,
io__state, io__state).
:- mode build_mercury_type(in, in, out, di, uo) is det.
-build_mercury_type(Type, TypeCategory, GCC_Type) -->
+build_mercury_type(Type, CtorCat, GCC_Type) -->
(
- { TypeCategory = type_cat_char },
+ { CtorCat = ctor_cat_builtin(cat_builtin_char) },
{ GCC_Type = 'MR_Char' }
;
- { TypeCategory = type_cat_int },
+ { CtorCat = ctor_cat_builtin(cat_builtin_int) },
{ GCC_Type = 'MR_Integer' }
;
- { TypeCategory = type_cat_string },
+ { CtorCat = ctor_cat_builtin(cat_builtin_string) },
{ GCC_Type = 'MR_String' }
;
- { TypeCategory = type_cat_float },
+ { CtorCat = ctor_cat_builtin(cat_builtin_float) },
{ GCC_Type = 'MR_Float' }
;
- { TypeCategory = type_cat_void },
+ { CtorCat = ctor_cat_void },
{ GCC_Type = 'MR_Word' }
;
- { TypeCategory = type_cat_type_info },
- build_mercury_type(Type, type_cat_user_ctor, GCC_Type)
+ { CtorCat = ctor_cat_system(cat_system_type_info) },
+ build_mercury_type(Type, ctor_cat_user(cat_user_general),
+ GCC_Type)
+ ;
+ { CtorCat = ctor_cat_system(cat_system_type_ctor_info) },
+ build_mercury_type(Type, ctor_cat_user(cat_user_general),
+ GCC_Type)
;
- { TypeCategory = type_cat_type_ctor_info },
- build_mercury_type(Type, type_cat_user_ctor, GCC_Type)
- ;
- { TypeCategory = type_cat_typeclass_info },
+ { CtorCat = ctor_cat_system(cat_system_typeclass_info) },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file,
@@ -1894,7 +1896,7 @@
{ GCC_Type = 'MR_Word' }
)
;
- { TypeCategory = type_cat_base_typeclass_info },
+ { CtorCat = ctor_cat_system(cat_system_base_typeclass_info) },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file,
@@ -1903,16 +1905,16 @@
{ GCC_Type = 'MR_Word' }
)
;
- { TypeCategory = type_cat_variable },
+ { CtorCat = ctor_cat_variable },
{ GCC_Type = 'MR_Box' }
;
- { TypeCategory = type_cat_tuple },
+ { CtorCat = ctor_cat_tuple },
% tuples are always (pointers to)
% arrays of polymorphic terms
gcc__build_pointer_type('MR_Box', MR_Tuple),
{ GCC_Type = MR_Tuple }
;
- { TypeCategory = type_cat_higher_order },
+ { CtorCat = ctor_cat_higher_order },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file, "--high-level-data (pred_type)") }
@@ -1921,9 +1923,8 @@
{ GCC_Type = 'MR_Word' }
)
;
- { TypeCategory = type_cat_enum
- ; TypeCategory = type_cat_dummy
- ; TypeCategory = type_cat_foreign_enum
+ { CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
},
% Note that the MLDS -> C back-end uses 'MR_Word' here,
% unless --high-level-data is enabled. But 'MR_Integer'
@@ -1932,7 +1933,7 @@
% XXX for --high-level-data, we should use a real enum type
{ GCC_Type = 'MR_Integer' }
;
- { TypeCategory = type_cat_user_ctor },
+ { CtorCat = ctor_cat_user(_) },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file, "--high-level-data (user_type)") }
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.196
diff -u -b -r1.196 mlds_to_il.m
--- compiler/mlds_to_il.m 31 Dec 2007 10:03:50 -0000 1.196
+++ compiler/mlds_to_il.m 8 Feb 2008 07:37:37 -0000
@@ -1198,7 +1198,8 @@
UnivSymName = qualified(unqualified("univ"), "univ"),
UnivMercuryType = defined_type(UnivSymName, [], kind_star),
UnivMLDSType = mercury_type(UnivMercuryType,
- type_cat_user_ctor, non_foreign_type(UnivMercuryType)),
+ ctor_cat_user(cat_user_general),
+ non_foreign_type(UnivMercuryType)),
UnivType = mlds_type_to_ilds_type(DataRep, UnivMLDSType),
RenameNode = (func(N) = list.map(RenameRets, N)),
@@ -2058,7 +2059,7 @@
Type = mlds_class_type(_, _, mlds_class)
;
DataRep ^ highlevel_data = yes,
- Type = mercury_type(MercuryType, type_cat_user_ctor, _),
+ Type = mercury_type(MercuryType, ctor_cat_user(_), _),
\+ type_needs_lowlevel_rep(target_il, MercuryType)
)
->
@@ -2613,12 +2614,12 @@
;
( already_boxed(SrcILType) ->
(
- SrcType = mercury_type(_, TypeCategory, _),
+ SrcType = mercury_type(_, TypeCtorCategory, _),
% XXX Consider whether this is the right way to handle
% type_infos, type_ctor_infos, typeclass_infos and
% base_typeclass_infos.
- ( TypeCategory = type_cat_user_ctor
- ; is_introduced_type_info_type_category(TypeCategory) = yes
+ ( TypeCtorCategory = ctor_cat_user(_)
+ ; is_introduced_type_info_type_category(TypeCtorCategory) = yes
)
->
% XXX We should look into a nicer way to generate MLDS
@@ -3110,7 +3111,7 @@
mlds_type_to_ilds_type(_, mlds_tabling_type(_Id)) = il_object_array_type.
mlds_type_to_ilds_type(DataRep, mlds_mercury_array_type(ElementType)) =
- ( ElementType = mercury_type(_, type_cat_variable, _) ->
+ ( ElementType = mercury_type(_, ctor_cat_variable, _) ->
il_generic_array_type
;
il_type([], '[]'(mlds_type_to_ilds_type(DataRep, ElementType), []))
@@ -3200,38 +3201,47 @@
% of type void, so the type is moot.
%
:- func mlds_mercury_type_to_ilds_type(il_data_rep, mer_type,
- type_category) = il_type.
+ type_ctor_category) = il_type.
-mlds_mercury_type_to_ilds_type(_, _, type_cat_int) = il_type([], int32).
-mlds_mercury_type_to_ilds_type(_, _, type_cat_char) = il_type([], char).
-mlds_mercury_type_to_ilds_type(_, _, type_cat_float) = il_type([], float64).
-mlds_mercury_type_to_ilds_type(_, _, type_cat_string) = il_string_type.
-mlds_mercury_type_to_ilds_type(_, _, type_cat_void) = il_type([], int32).
-mlds_mercury_type_to_ilds_type(_, _, type_cat_higher_order) =
- il_object_array_type.
-mlds_mercury_type_to_ilds_type(_, _, type_cat_tuple) = il_object_array_type.
-mlds_mercury_type_to_ilds_type(_, _, type_cat_enum) = il_object_array_type.
-mlds_mercury_type_to_ilds_type(_, _, type_cat_foreign_enum) =
- il_object_array_type.
-mlds_mercury_type_to_ilds_type(_, _, type_cat_dummy) = il_generic_type.
-mlds_mercury_type_to_ilds_type(_, _, type_cat_variable) = il_generic_type.
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_type_info) =
- mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor).
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_type_ctor_info) =
- mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor).
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_typeclass_info) =
- mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor).
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType,
- type_cat_base_typeclass_info) =
- mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor).
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor) =
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, CtorCat) = ILType :-
+ (
+ ( CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_void
+ ),
+ ILType = il_type([], int32)
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
+ ILType = il_type([], char)
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
+ ILType = il_type([], float64)
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
+ ILType = il_string_type
+ ;
+ ( CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_enum(_)
+ ),
+ ILType = il_object_array_type
+ ;
+ ( CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ),
+ ILType = il_generic_type
+ ;
+ % We should handle ctor_cat_user(cat_user_direct_dummy) specially.
+ ( CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_user(_)
+ ),
(
DataRep ^ highlevel_data = yes,
\+ type_needs_lowlevel_rep(target_il, MercuryType)
->
- mercury_type_to_highlevel_class_type(MercuryType)
+ ILType = mercury_type_to_highlevel_class_type(MercuryType)
;
- il_object_array_type
+ ILType = il_object_array_type
+ )
).
:- func mlds_class_to_ilds_simple_type(mlds_class_kind, ilds.class_name) =
@@ -3728,23 +3738,26 @@
rval_const_to_type(mlconst_data_addr(_)) = mlds_array_type(mlds_generic_type).
rval_const_to_type(mlconst_code_addr(_))
= mlds_func_type(mlds_func_params([], [])).
-rval_const_to_type(mlconst_int(_))
- = mercury_type(IntType, type_cat_int, non_foreign_type(IntType)) :-
- IntType = builtin_type(builtin_type_int).
+rval_const_to_type(mlconst_int(_)) = MLDSType :-
+ IntType = builtin_type(builtin_type_int),
+ MLDSType = mercury_type(IntType, ctor_cat_builtin(cat_builtin_int),
+ non_foreign_type(IntType)).
rval_const_to_type(mlconst_foreign(_, _, _))
= sorry(this_file, "IL backend and foreign tag.").
-rval_const_to_type(mlconst_float(_))
- = mercury_type(FloatType, type_cat_float,
- non_foreign_type(FloatType)) :-
- FloatType = builtin_type(builtin_type_float).
+rval_const_to_type(mlconst_float(_)) = MLDSType :-
+ FloatType = builtin_type(builtin_type_float),
+ MLDSType = mercury_type(FloatType, ctor_cat_builtin(cat_builtin_float),
+ non_foreign_type(FloatType)).
rval_const_to_type(mlconst_false) = mlds_native_bool_type.
rval_const_to_type(mlconst_true) = mlds_native_bool_type.
-rval_const_to_type(mlconst_string(_))
- = mercury_type(StrType, type_cat_string, non_foreign_type(StrType)) :-
- StrType = builtin_type(builtin_type_string).
-rval_const_to_type(mlconst_multi_string(_))
- = mercury_type(StrType, type_cat_string, non_foreign_type(StrType)) :-
- StrType = builtin_type(builtin_type_string).
+rval_const_to_type(mlconst_string(_)) = MLDSType :-
+ StrType = builtin_type(builtin_type_string),
+ MLDSType = mercury_type(StrType, ctor_cat_builtin(cat_builtin_string),
+ non_foreign_type(StrType)).
+rval_const_to_type(mlconst_multi_string(_)) = MLDSType :-
+ StrType = builtin_type(builtin_type_string),
+ MLDSType = mercury_type(StrType, ctor_cat_builtin(cat_builtin_string),
+ non_foreign_type(StrType)).
rval_const_to_type(mlconst_named_const(_))
= sorry(this_file, "IL backend and named const.").
rval_const_to_type(mlconst_null(MldsType)) = MldsType.
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.101
diff -u -b -r1.101 mlds_to_java.m
--- compiler/mlds_to_java.m 31 Dec 2007 10:03:50 -0000 1.101
+++ compiler/mlds_to_java.m 8 Feb 2008 07:57:14 -0000
@@ -182,7 +182,8 @@
type_is_enum(Type) :-
Type = mercury_type(_, Builtin, _),
- Builtin = type_cat_enum.
+ % XXX Should this succeed also for cat_enum_foreign?
+ Builtin = ctor_cat_enum(cat_enum_mercury).
% Succeeds iff this type is something that the Java backend will represent
% as an object i.e. something created using the new operator.
@@ -190,27 +191,28 @@
:- pred type_is_object(mlds_type::in) is semidet.
type_is_object(Type) :-
- Type = mercury_type(_, TypeCategory, _),
- type_category_is_object(TypeCategory) = yes.
+ Type = mercury_type(_, CtorCat, _),
+ type_category_is_object(CtorCat) = yes.
-:- func type_category_is_object(type_category) = bool.
+:- func type_category_is_object(type_ctor_category) = bool.
-type_category_is_object(type_cat_int) = no.
-type_category_is_object(type_cat_char) = no.
-type_category_is_object(type_cat_string) = no.
-type_category_is_object(type_cat_float) = no.
-type_category_is_object(type_cat_higher_order) = no.
-type_category_is_object(type_cat_tuple) = no.
-type_category_is_object(type_cat_enum) = yes.
-type_category_is_object(type_cat_foreign_enum) = yes.
-type_category_is_object(type_cat_dummy) = yes.
-type_category_is_object(type_cat_variable) = yes.
-type_category_is_object(type_cat_type_info) = yes.
-type_category_is_object(type_cat_type_ctor_info) = yes.
-type_category_is_object(type_cat_typeclass_info) = yes.
-type_category_is_object(type_cat_base_typeclass_info) = yes.
-type_category_is_object(type_cat_void) = no.
-type_category_is_object(type_cat_user_ctor) = yes.
+type_category_is_object(CtorCat) = IsObject :-
+ (
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_void
+ ),
+ IsObject = no
+ ;
+ ( CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_user(_)
+ ),
+ IsObject = yes
+ ).
% Given an lval, return its type.
%
@@ -1437,45 +1439,59 @@
%
:- func get_java_type_initializer(mlds_type) = string.
-get_java_type_initializer(mercury_type(_, type_cat_int, _)) = "0".
-get_java_type_initializer(mercury_type(_, type_cat_char, _)) = "0".
-get_java_type_initializer(mercury_type(_, type_cat_float, _)) = "0".
-get_java_type_initializer(mercury_type(_, type_cat_string, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_cat_void, _)) = "0".
-get_java_type_initializer(mercury_type(_, type_cat_type_info, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_cat_type_ctor_info, _))
- = "null".
-get_java_type_initializer(mercury_type(_, type_cat_typeclass_info, _))
- = "null".
-get_java_type_initializer(mercury_type(_, type_cat_base_typeclass_info, _))
- = "null".
-get_java_type_initializer(mercury_type(_, type_cat_higher_order, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_cat_tuple, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_cat_enum, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_cat_foreign_enum, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_cat_dummy, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_cat_variable, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_cat_user_ctor, _)) = "null".
-get_java_type_initializer(mlds_mercury_array_type(_)) = "null".
-get_java_type_initializer(mlds_cont_type(_)) = "null".
-get_java_type_initializer(mlds_commit_type) = "null".
-get_java_type_initializer(mlds_native_bool_type) = "false".
-get_java_type_initializer(mlds_native_int_type) = "0".
-get_java_type_initializer(mlds_native_float_type) = "0".
-get_java_type_initializer(mlds_native_char_type) = "0".
-get_java_type_initializer(mlds_foreign_type(_)) = "null".
-get_java_type_initializer(mlds_class_type(_, _, _)) = "null".
-get_java_type_initializer(mlds_array_type(_)) = "null".
-get_java_type_initializer(mlds_ptr_type(_)) = "null".
-get_java_type_initializer(mlds_func_type(_)) = "null".
-get_java_type_initializer(mlds_generic_type) = "null".
-get_java_type_initializer(mlds_generic_env_ptr_type) = "null".
-get_java_type_initializer(mlds_type_info_type) = "null".
-get_java_type_initializer(mlds_pseudo_type_info_type) = "null".
-get_java_type_initializer(mlds_rtti_type(_)) = "null".
-get_java_type_initializer(mlds_tabling_type(_)) = "null".
-get_java_type_initializer(mlds_unknown_type) = _ :-
- unexpected(this_file, "get_type_initializer: variable has unknown_type").
+get_java_type_initializer(Type) = Initializer :-
+ (
+ Type = mercury_type(_, CtorCat, _),
+ (
+ ( CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_char)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_float)
+ ; CtorCat = ctor_cat_void
+ ),
+ Initializer = "0"
+ ;
+ ( CtorCat = ctor_cat_builtin(cat_builtin_string)
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_user(_)
+ ),
+ Initializer = "null"
+ )
+ ;
+ ( Type = mlds_native_int_type
+ ; Type = mlds_native_float_type
+ ; Type = mlds_native_char_type
+ ),
+ Initializer = "0"
+ ;
+ Type = mlds_native_bool_type,
+ Initializer = "false"
+ ;
+ ( Type = mlds_mercury_array_type(_)
+ ; Type = mlds_cont_type(_)
+ ; Type = mlds_commit_type
+ ; Type = mlds_foreign_type(_)
+ ; Type = mlds_class_type(_, _, _)
+ ; Type = mlds_array_type(_)
+ ; Type = mlds_ptr_type(_)
+ ; Type = mlds_func_type(_)
+ ; Type = mlds_generic_type
+ ; Type = mlds_generic_env_ptr_type
+ ; Type = mlds_type_info_type
+ ; Type = mlds_pseudo_type_info_type
+ ; Type = mlds_rtti_type(_)
+ ; Type = mlds_tabling_type(_)
+ ),
+ Initializer = "null"
+ ;
+ Type = mlds_unknown_type,
+ unexpected(this_file,
+ "get_type_initializer: variable has unknown_type")
+ ).
:- pred output_maybe(maybe(T)::in,
pred(T, io, io)::pred(in, di, uo) is det, io::di, io::uo) is det.
@@ -1828,7 +1844,7 @@
:- pred output_type(mlds_type::in, io::di, io::uo) is det.
-output_type(mercury_type(Type, TypeCategory, _), !IO) :-
+output_type(mercury_type(Type, CtorCat, _), !IO) :-
( Type = c_pointer_type ->
% The c_pointer type is used in the c back-end as a generic way
% to pass foreign types to automatically generated Compare and Unify
@@ -1837,15 +1853,15 @@
;
% We need to handle type_info (etc.) types specially -- they get mapped
% to types in the runtime rather than in private_builtin.
- hand_defined_type(TypeCategory, SubstituteName)
+ hand_defined_type(CtorCat, SubstituteName)
->
io.write_string(SubstituteName, !IO)
;
- output_mercury_type(Type, TypeCategory, !IO)
+ output_mercury_type(Type, CtorCat, !IO)
).
output_type(mlds_mercury_array_type(ElementType), !IO) :-
- ( ElementType = mercury_type(_, type_cat_variable, _) ->
+ ( ElementType = mercury_type(_, ctor_cat_variable, _) ->
% We can't use `java.lang.Object []', since we want a generic type
% that is capable of holding any kind of array, including e.g.
% `int []'. Java doesn't have any equivalent of .NET's System.Array
@@ -1925,68 +1941,54 @@
output_type(mlds_unknown_type, !IO) :-
unexpected(this_file, "output_type: unknown type").
-:- pred output_mercury_type(mer_type::in, type_category::in,
+:- pred output_mercury_type(mer_type::in, type_ctor_category::in,
io::di, io::uo) is det.
-output_mercury_type(Type, TypeCategory, !IO) :-
+output_mercury_type(Type, CtorCat, !IO) :-
(
- TypeCategory = type_cat_char,
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
io.write_string("char", !IO)
;
- TypeCategory = type_cat_int,
+ CtorCat = ctor_cat_builtin(cat_builtin_int),
io.write_string("int", !IO)
;
- TypeCategory = type_cat_string,
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
io.write_string("java.lang.String", !IO)
;
- TypeCategory = type_cat_float,
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
io.write_string("double", !IO)
;
- TypeCategory = type_cat_void,
+ CtorCat = ctor_cat_void,
% Shouldn't matter what we put here.
io.write_string("int", !IO)
;
- TypeCategory = type_cat_type_info,
- output_mercury_user_type(Type, type_cat_user_ctor, !IO)
- ;
- TypeCategory = type_cat_type_ctor_info,
- output_mercury_user_type(Type, type_cat_user_ctor, !IO)
- ;
- TypeCategory = type_cat_typeclass_info,
- output_mercury_user_type(Type, type_cat_user_ctor, !IO)
- ;
- TypeCategory = type_cat_base_typeclass_info,
- output_mercury_user_type(Type, type_cat_user_ctor, !IO)
- ;
- TypeCategory = type_cat_variable,
+ CtorCat = ctor_cat_variable,
io.write_string("java.lang.Object", !IO)
;
- TypeCategory = type_cat_tuple,
+ CtorCat = ctor_cat_tuple,
io.write_string("/* tuple */ java.lang.Object[]", !IO)
;
- TypeCategory = type_cat_higher_order,
+ CtorCat = ctor_cat_higher_order,
io.write_string("/* closure */ java.lang.Object[]", !IO)
;
- TypeCategory = type_cat_enum,
- output_mercury_user_type(Type, TypeCategory, !IO)
- ;
- TypeCategory = type_cat_foreign_enum,
- output_mercury_user_type(Type, TypeCategory, !IO)
+ CtorCat = ctor_cat_system(_),
+ output_mercury_user_type(Type, ctor_cat_user(cat_user_general), !IO)
;
- TypeCategory = type_cat_dummy,
- output_mercury_user_type(Type, TypeCategory, !IO)
- ;
- TypeCategory = type_cat_user_ctor,
- output_mercury_user_type(Type, TypeCategory, !IO)
+ ( CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ),
+ output_mercury_user_type(Type, CtorCat, !IO)
).
-:- pred output_mercury_user_type(mer_type::in, type_category::in,
+:- pred output_mercury_user_type(mer_type::in, type_ctor_category::in,
io::di, io::uo) is det.
-output_mercury_user_type(Type, TypeCategory, !IO) :-
+output_mercury_user_type(Type, CtorCat, !IO) :-
( type_to_ctor_and_args(Type, TypeCtor, _ArgsTypes) ->
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
- ( TypeCategory = type_cat_enum ->
+ % XXX Should the test succeed for cat_enum_foreign?
+ ( CtorCat = ctor_cat_enum(cat_enum_mercury) ->
MLDS_Type = mlds_class_type(ClassName, ClassArity, mlds_enum)
;
MLDS_Type = mlds_class_type(ClassName, ClassArity, mlds_class)
@@ -2005,8 +2007,8 @@
IsArray = is_array
; Type = mlds_mercury_array_type(_) ->
IsArray = is_array
- ; Type = mercury_type(_, TypeCategory, _) ->
- IsArray = type_category_is_array(TypeCategory)
+ ; Type = mercury_type(_, CtorCat, _) ->
+ IsArray = type_category_is_array(CtorCat)
; Type = mlds_rtti_type(RttiIdMaybeElement) ->
rtti_id_maybe_element_java_type(RttiIdMaybeElement,
_JavaTypeName, IsArray)
@@ -2016,39 +2018,51 @@
% Return is_array if the corresponding Java type is an array type.
%
-:- func type_category_is_array(type_category) = is_array.
+:- func type_category_is_array(type_ctor_category) = is_array.
-type_category_is_array(type_cat_int) = not_array.
-type_category_is_array(type_cat_char) = not_array.
-type_category_is_array(type_cat_string) = not_array.
-type_category_is_array(type_cat_float) = not_array.
-type_category_is_array(type_cat_higher_order) = is_array.
-type_category_is_array(type_cat_tuple) = is_array.
-type_category_is_array(type_cat_enum) = not_array.
-type_category_is_array(type_cat_foreign_enum) = not_array.
-type_category_is_array(type_cat_dummy) = not_array.
-type_category_is_array(type_cat_variable) = not_array.
-type_category_is_array(type_cat_type_info) = not_array.
-type_category_is_array(type_cat_type_ctor_info) = not_array.
-type_category_is_array(type_cat_typeclass_info) = is_array.
-type_category_is_array(type_cat_base_typeclass_info) = is_array.
-type_category_is_array(type_cat_void) = not_array.
-type_category_is_array(type_cat_user_ctor) = not_array.
+type_category_is_array(CtorCat) = IsArray :-
+ (
+ % XXX I am not sure about ctor_cat_variable.
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_system(cat_system_type_info)
+ ; CtorCat = ctor_cat_system(cat_system_type_ctor_info)
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_user(_)
+ ),
+ IsArray = not_array
+ ;
+ ( CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_system(cat_system_typeclass_info)
+ ; CtorCat = ctor_cat_system(cat_system_base_typeclass_info)
+ ),
+ IsArray = is_array
+ ).
% hand_defined_type(Type, SubstituteName):
%
% We need to handle type_info (etc.) types specially -- they get mapped
% to types in the runtime rather than in private_builtin.
%
-:- pred hand_defined_type(type_category::in, string::out) is semidet.
+:- pred hand_defined_type(type_ctor_category::in, string::out) is semidet.
-hand_defined_type(type_cat_type_info, "mercury.runtime.TypeInfo_Struct").
-hand_defined_type(type_cat_type_ctor_info,
- "mercury.runtime.TypeCtorInfo_Struct").
-hand_defined_type(type_cat_base_typeclass_info,
- "/* base_typeclass_info */ java.lang.Object[]").
-hand_defined_type(type_cat_typeclass_info,
- "/* typeclass_info */ java.lang.Object[]").
+hand_defined_type(ctor_cat_system(Kind), SubstituteName) :-
+ (
+ Kind = cat_system_type_info,
+ SubstituteName = "mercury.runtime.TypeInfo_Struct"
+ ;
+ Kind = cat_system_type_ctor_info,
+ SubstituteName = "mercury.runtime.TypeCtorInfo_Struct"
+ ;
+ Kind = cat_system_typeclass_info,
+ SubstituteName = "/* typeclass_info */ java.lang.Object[]"
+ ;
+ Kind = cat_system_base_typeclass_info,
+ SubstituteName = "/* base_typeclass_info */ java.lang.Object[]"
+ ).
%-----------------------------------------------------------------------------%
%
@@ -2613,7 +2627,7 @@
Var = lval(Lval),
Lval = var(_VarName, VarType),
VarType = mercury_type(ProgDataType, _, _),
- is_dummy_argument_type(ModuleInfo, ProgDataType)
+ check_dummy_type(ModuleInfo, ProgDataType) = is_dummy_type
->
VarList = Vars
;
@@ -2819,8 +2833,8 @@
(
MaybeCtorName = yes(QualifiedCtorId),
\+ (
- Type = mercury_type(_, TypeCategory, _),
- hand_defined_type(TypeCategory, _)
+ Type = mercury_type(_, CtorCat, _),
+ hand_defined_type(CtorCat, _)
)
->
output_type(Type, !IO),
@@ -3099,7 +3113,7 @@
output_rval(ModuleInfo, Exprn, ModuleName, !IO),
io.write_string(")", !IO)
;
- ( Type = mercury_type(_, type_cat_type_info, _)
+ ( Type = mercury_type(_, ctor_cat_system(cat_system_type_info), _)
; Type = mlds_type_info_type
)
->
@@ -3201,7 +3215,7 @@
% types are defined types, but enables the compiler to infer that
% this disjunction is a switch.
Type = mercury_type(MercuryType @ defined_type(_, _, _), _, _),
- is_dummy_argument_type(ModuleInfo, MercuryType).
+ check_dummy_type(ModuleInfo, MercuryType) = is_dummy_type.
:- pred output_std_unop(module_info::in, builtin_ops.unary_op::in,
mlds_rval::in, mlds_module_name::in, io::di, io::uo) is det.
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.204
diff -u -b -r1.204 opt_debug.m
--- compiler/opt_debug.m 23 Jan 2008 11:44:46 -0000 1.204
+++ compiler/opt_debug.m 8 Feb 2008 08:41:58 -0000
@@ -117,6 +117,7 @@
:- import_module backend_libs.c_util.
:- import_module backend_libs.proc_label.
+:- import_module check_hlds.type_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_rtti.
:- import_module hlds.special_pred.
@@ -1097,10 +1098,10 @@
dump_lval(MaybeProcLabel, Lval) ++ " := " ++ Var ++
dump_maybe_dummy(Dummy).
-:- func dump_maybe_dummy(bool) = string.
+:- func dump_maybe_dummy(is_dummy_type) = string.
-dump_maybe_dummy(no) = "".
-dump_maybe_dummy(yes) = " (dummy)".
+dump_maybe_dummy(is_not_dummy_type) = "".
+dump_maybe_dummy(is_dummy_type) = " (dummy)".
dump_fullinstr(ProcLabel, PrintComments, llds_instr(Uinstr, Comment)) = Str :-
(
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.168
diff -u -b -r1.168 opt_util.m
--- compiler/opt_util.m 30 Dec 2007 08:23:52 -0000 1.168
+++ compiler/opt_util.m 8 Feb 2008 08:40:10 -0000
@@ -321,6 +321,7 @@
:- implementation.
:- import_module backend_libs.builtin_ops.
+:- import_module check_hlds.type_util.
:- import_module hlds.special_pred.
:- import_module libs.compiler_util.
:- import_module ll_backend.exprn_aux.
@@ -968,10 +969,10 @@
Input = foreign_proc_input(_Name, _Type, IsDummy, _OrigType, Rval,
_MaybeForeign, _BoxPolicy),
(
- IsDummy = yes,
+ IsDummy = is_dummy_type,
Refers = no
;
- IsDummy = no,
+ IsDummy = is_not_dummy_type,
Refers = rval_refers_stackvars(Rval)
).
@@ -981,10 +982,10 @@
Input = foreign_proc_output(Lval, _Type, IsDummy, _OrigType, _Name,
_MaybeForeign, _BoxPolicy),
(
- IsDummy = yes,
+ IsDummy = is_dummy_type,
Refers = no
;
- IsDummy = no,
+ IsDummy = is_not_dummy_type,
Refers = lval_refers_stackvars(Lval)
).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.326
diff -u -b -r1.326 polymorphism.m
--- compiler/polymorphism.m 29 Jan 2008 04:59:41 -0000 1.326
+++ compiler/polymorphism.m 8 Feb 2008 03:38:04 -0000
@@ -2703,26 +2703,40 @@
unexpected(this_file, "get_special_proc_det: get_special_proc failed")
).
-:- func get_category_name(type_category) = maybe(string).
+:- func get_category_name(type_ctor_category) = maybe(string).
-get_category_name(type_cat_int) = yes("int").
-get_category_name(type_cat_char) = yes("int").
-get_category_name(type_cat_enum) = no.
-get_category_name(type_cat_foreign_enum) = no.
-get_category_name(type_cat_dummy) = no.
-get_category_name(type_cat_float) = yes("float").
-get_category_name(type_cat_string) = yes("string").
-get_category_name(type_cat_higher_order) = yes("pred").
-get_category_name(type_cat_tuple) = yes("tuple").
-get_category_name(type_cat_variable) = _ :-
- unexpected(this_file, "get_category_name: variable type").
-get_category_name(type_cat_void) = _ :-
- unexpected(this_file, "get_category_name: void_type").
-get_category_name(type_cat_user_ctor) = no.
-get_category_name(type_cat_type_info) = no.
-get_category_name(type_cat_type_ctor_info) = no.
-get_category_name(type_cat_typeclass_info) = no.
-get_category_name(type_cat_base_typeclass_info) = no.
+get_category_name(CtorCat) = MaybeName :-
+ (
+ ( CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_char)
+ ),
+ MaybeName = yes("int")
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
+ MaybeName = yes("float")
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
+ MaybeName = yes("string")
+ ;
+ CtorCat = ctor_cat_higher_order,
+ MaybeName = yes("pred")
+ ;
+ CtorCat = ctor_cat_tuple,
+ MaybeName = yes("tuple")
+ ;
+ ( CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_system(_)
+ ),
+ MaybeName = no
+ ;
+ CtorCat = ctor_cat_variable,
+ unexpected(this_file, "get_category_name: variable type")
+ ;
+ CtorCat = ctor_cat_void,
+ unexpected(this_file, "get_category_name: void_type")
+ ).
init_type_info_var(Type, ArgVars, MaybePreferredVar, TypeInfoVar, TypeInfoGoal,
!VarSet, !VarTypes, !RttiVarMaps) :-
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.111
diff -u -b -r1.111 pragma_c_gen.m
--- compiler/pragma_c_gen.m 26 Nov 2007 05:13:21 -0000 1.111
+++ compiler/pragma_c_gen.m 8 Feb 2008 07:59:04 -0000
@@ -1417,11 +1417,7 @@
produce_variable(Var, FirstCode, Rval, !CI),
MaybeForeign = get_maybe_foreign_type_info(!.CI, OrigType),
get_module_info(!.CI, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, VarType) ->
- IsDummy = yes
- ;
- IsDummy = no
- ),
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
Input = foreign_proc_input(Name, VarType, IsDummy, OrigType, Rval,
MaybeForeign, BoxPolicy),
get_foreign_proc_input_vars(Args, Inputs1, CanOptAwayUnnamedArgs,
@@ -1502,11 +1498,7 @@
MaybeName = yes(Name),
get_module_info(!.CI, ModuleInfo),
VarType = variable_type(!.CI, Var),
- ( is_dummy_argument_type(ModuleInfo, VarType) ->
- IsDummy = yes
- ;
- IsDummy = no
- ),
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
PragmaCOutput = foreign_proc_output(Reg, VarType, IsDummy,
OrigType, Name, MaybeForeign, BoxPolicy),
Outputs = [PragmaCOutput | OutputsTail]
@@ -1544,11 +1536,7 @@
Reg = reg(reg_r, N),
MaybeForeign = get_maybe_foreign_type_info(CI, OrigType),
get_module_info(CI, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, VarType) ->
- IsDummy = yes
- ;
- IsDummy = no
- ),
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
Input = foreign_proc_input(Name, VarType, IsDummy, OrigType, lval(Reg),
MaybeForeign, BoxPolicy),
Inputs = [Input | InputsTail]
@@ -1578,11 +1566,7 @@
Reg = reg(reg_r, N),
MaybeForeign = get_maybe_foreign_type_info(CI, OrigType),
get_module_info(CI, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, VarType) ->
- IsDummy = yes
- ;
- IsDummy = no
- ),
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
Output = foreign_proc_output(Reg, VarType, IsDummy, OrigType, Name,
MaybeForeign, BoxPolicy),
Outputs = [Output | OutputsTail]
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.42
diff -u -b -r1.42 prog_type.m
--- compiler/prog_type.m 23 Nov 2007 07:35:22 -0000 1.42
+++ compiler/prog_type.m 8 Feb 2008 10:34:28 -0000
@@ -206,12 +206,16 @@
%
:- func builtin_type_ctors_with_no_hlds_type_defn = list(type_ctor).
- % is_builtin_dummy_argument_type(type_ctor):
+:- type is_builtin_dummy_type_ctor
+ ---> is_builtin_dummy_type_ctor
+ ; is_not_builtin_dummy_type_ctor.
+
+ % is_builtin_dummy_type_ctor(type_ctor):
%
% Is the given type constructor a dummy type irrespective
% of its definition?
%
-:- pred is_builtin_dummy_argument_type(type_ctor::in) is semidet.
+:- func check_builtin_dummy_type_ctor(type_ctor) = is_builtin_dummy_type_ctor.
% Certain types, e.g. io.state and store.store(S), are just dummy types
% used to ensure logical semantics; there is no need to actually pass them,
@@ -240,7 +244,7 @@
:- pred is_introduced_type_info_type_ctor(type_ctor::in) is semidet.
-:- func is_introduced_type_info_type_category(type_category) = bool.
+:- func is_introduced_type_info_type_category(type_ctor_category) = bool.
% Given a list of variables, return the permutation
% of that list which has all the type_info-related variables
@@ -268,23 +272,37 @@
:- mode remove_new_prefix(in, out) is semidet.
:- mode remove_new_prefix(out, in) is det.
-:- type type_category
- ---> type_cat_int
- ; type_cat_char
- ; type_cat_string
- ; type_cat_float
- ; type_cat_higher_order
- ; type_cat_tuple
- ; type_cat_enum
- ; type_cat_foreign_enum
- ; type_cat_dummy
- ; type_cat_variable
- ; type_cat_type_info
- ; type_cat_type_ctor_info
- ; type_cat_typeclass_info
- ; type_cat_base_typeclass_info
- ; type_cat_void
- ; type_cat_user_ctor.
+:- type type_ctor_category
+ ---> ctor_cat_builtin(type_ctor_cat_builtin)
+ ; ctor_cat_higher_order
+ ; ctor_cat_tuple
+ ; ctor_cat_enum(type_ctor_cat_enum)
+ ; ctor_cat_builtin_dummy
+ ; ctor_cat_variable
+ ; ctor_cat_system(type_ctor_cat_system)
+ ; ctor_cat_void
+ ; ctor_cat_user(type_ctor_cat_user).
+
+:- type type_ctor_cat_builtin
+ ---> cat_builtin_int
+ ; cat_builtin_float
+ ; cat_builtin_char
+ ; cat_builtin_string.
+
+:- type type_ctor_cat_system
+ ---> cat_system_type_info
+ ; cat_system_type_ctor_info
+ ; cat_system_typeclass_info
+ ; cat_system_base_typeclass_info.
+
+:- type type_ctor_cat_enum
+ ---> cat_enum_mercury
+ ; cat_enum_foreign.
+
+:- type type_ctor_cat_user
+ ---> cat_user_direct_dummy
+ ; cat_user_notag
+ ; cat_user_general.
% Construct builtin types.
%
@@ -350,34 +368,20 @@
% functor result type
).
- % Check whether the type with the given list of constructors would be
- % a no_tag type (which requires the list to include exactly one constructor
- % with exactly one argument), and if so, return its constructor symbol,
- % argument type, and the argument's name (if it has one).
- %
- % This doesn't do any checks for options that might be set (such as
- % turning off no_tag_types). If you want those checks you should use
- % type_is_no_tag_type/4, or if you really know what you are doing,
- % perform the checks yourself.
- %
-:- pred type_constructors_are_no_tag_type(list(constructor)::in, sym_name::out,
- mer_type::out, maybe(string)::out) is semidet.
-
% Given a list of constructors for a type, check whether that type
% is a private_builtin.type_info/0 or similar type.
%
:- pred type_constructors_are_type_info(list(constructor)::in) is semidet.
- % type_with_constructors_should_be_no_tag(Globals, TypeCtor, ReservedTag,
- % Ctors, UserEqComp, FunctorName, FunctorArgType, MaybeFunctorArgName):
+ % type_ctor_should_be_notag(Globals, TypeCtor, ReservedTag, Ctors,
+ % MaybeUserEqComp, SingleFunctorName, SingleArgType, MaybeSingleArgName):
%
- % Check whether some constructors are a no_tag type, and that this
- % is compatible with the ReservedTag setting for this type and
- % the grade options set in the globals.
- % Assign single functor of arity one a `no_tag' tag (unless we are
- % reserving a tag, or if it is one of the dummy types).
+ % Succeed if the type constructor with the given name (TypeCtor) and
+ % details (ReservedTag, Ctors, MaybeUserEqComp) is a no_tag type. If it is,
+ % return the name of its single function symbol, the type of its one
+ % argument, and its name (if any).
%
-:- pred type_with_constructors_should_be_no_tag(globals::in, type_ctor::in,
+:- pred type_ctor_should_be_notag(globals::in, type_ctor::in,
uses_reserved_tag::in, list(constructor)::in, maybe(unify_compare)::in,
sym_name::out, mer_type::out, maybe(string)::out) is semidet.
@@ -781,17 +785,24 @@
type_ctor(qualified(mercury_public_builtin_module, "tuple"), 0)
].
-is_builtin_dummy_argument_type(TypeCtor) :-
+check_builtin_dummy_type_ctor(TypeCtor) = IsBuiltinDummy :-
TypeCtor = type_ctor(CtorSymName, TypeArity),
- CtorSymName = qualified(ModuleName, TypeName),
(
+ CtorSymName = qualified(ModuleName, TypeName),
ModuleName = mercury_std_lib_module_name(unqualified("io")),
TypeName = "state",
TypeArity = 0
+ ->
+ IsBuiltinDummy = is_builtin_dummy_type_ctor
;
+ CtorSymName = qualified(ModuleName, TypeName),
ModuleName = mercury_std_lib_module_name(unqualified("store")),
TypeName = "store",
TypeArity = 1
+ ->
+ IsBuiltinDummy = is_builtin_dummy_type_ctor
+ ;
+ IsBuiltinDummy = is_not_builtin_dummy_type_ctor
).
constructor_list_represents_dummy_argument_type([Ctor], no) :-
@@ -820,22 +831,22 @@
; Name = "base_typeclass_info"
).
-is_introduced_type_info_type_category(type_cat_int) = no.
-is_introduced_type_info_type_category(type_cat_char) = no.
-is_introduced_type_info_type_category(type_cat_string) = no.
-is_introduced_type_info_type_category(type_cat_float) = no.
-is_introduced_type_info_type_category(type_cat_higher_order) = no.
-is_introduced_type_info_type_category(type_cat_tuple) = no.
-is_introduced_type_info_type_category(type_cat_enum) = no.
-is_introduced_type_info_type_category(type_cat_foreign_enum) = no.
-is_introduced_type_info_type_category(type_cat_dummy) = no.
-is_introduced_type_info_type_category(type_cat_variable) = no.
-is_introduced_type_info_type_category(type_cat_type_info) = yes.
-is_introduced_type_info_type_category(type_cat_type_ctor_info) = yes.
-is_introduced_type_info_type_category(type_cat_typeclass_info) = yes.
-is_introduced_type_info_type_category(type_cat_base_typeclass_info) = yes.
-is_introduced_type_info_type_category(type_cat_void) = no.
-is_introduced_type_info_type_category(type_cat_user_ctor) = no.
+is_introduced_type_info_type_category(TypeCtorCat) = IsIntroduced :-
+ (
+ ( TypeCtorCat = ctor_cat_builtin(_)
+ ; TypeCtorCat = ctor_cat_higher_order
+ ; TypeCtorCat = ctor_cat_tuple
+ ; TypeCtorCat = ctor_cat_enum(_)
+ ; TypeCtorCat = ctor_cat_builtin_dummy
+ ; TypeCtorCat = ctor_cat_variable
+ ; TypeCtorCat = ctor_cat_void
+ ; TypeCtorCat = ctor_cat_user(_)
+ ),
+ IsIntroduced = no
+ ;
+ TypeCtorCat = ctor_cat_system(_),
+ IsIntroduced = yes
+ ).
%-----------------------------------------------------------------------------%
@@ -862,7 +873,6 @@
is_introduced_type_info_type(Type)),
VarsList, TypeInfoVarsList, NonTypeInfoVarsList).
-
remove_new_prefix(unqualified(Name0), unqualified(Name)) :-
string.append("new ", Name, Name0).
remove_new_prefix(qualified(Module, Name0), qualified(Module, Name)) :-
@@ -990,23 +1000,14 @@
%-----------------------------------------------------------------------------%
-type_constructors_are_no_tag_type(Ctors, Ctor, ArgType, MaybeArgName) :-
- type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName0, ArgType),
-
- % We don't handle unary tuples as no_tag types -- they are rare enough
- % that it's not worth the implementation effort.
- Ctor \= unqualified("{}"),
-
- MaybeArgName = map_maybe(unqualify_name, MaybeArgName0).
-
type_constructors_are_type_info(Ctors) :-
type_is_single_ctor_single_arg(Ctors, Ctor, _, _),
ctor_is_type_info(Ctor).
:- pred type_is_single_ctor_single_arg(list(constructor)::in, sym_name::out,
- maybe(ctor_field_name)::out, mer_type::out) is semidet.
+ mer_type::out, maybe(ctor_field_name)::out) is semidet.
-type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName, ArgType) :-
+type_is_single_ctor_single_arg(Ctors, Ctor, ArgType, MaybeArgName) :-
Ctors = [SingleCtor],
SingleCtor = ctor(ExistQVars, _Constraints, Ctor,
[ctor_arg(MaybeArgName, ArgType, _)], _Ctxt),
@@ -1038,35 +1039,25 @@
%-----------------------------------------------------------------------------%
- % Assign single functor of arity one a `no_tag' tag (unless we are
- % reserving a tag, or if it is one of the dummy types).
- %
-type_with_constructors_should_be_no_tag(Globals, TypeCtor, ReserveTagPragma,
- Ctors, UserEqCmp, SingleFunc, SingleArg, MaybeArgName) :-
- type_constructors_are_no_tag_type(Ctors, SingleFunc, SingleArg,
- MaybeArgName),
- (
+type_ctor_should_be_notag(Globals, _TypeCtor, ReserveTagPragma, Ctors,
+ MaybeUserEqCmp, SingleFunctorName, SingleArgType,
+ MaybeSingleArgName) :-
ReserveTagPragma = does_not_use_reserved_tag,
- globals.lookup_bool_option(Globals, unboxed_no_tag_types, yes)
- ;
- % Dummy types always need to be treated as no-tag types as the
- % low-level C back end just passes around rubbish for them. When e.g.
- % using the debugger, it is crucial that these values are treated
- % as unboxed c_pointers, not as tagged pointers to c_pointers
- % (otherwise the system winds up following a bogus pointer).
- is_dummy_argument_type_with_constructors(TypeCtor, Ctors, UserEqCmp)
- ).
+ globals.lookup_bool_option(Globals, unboxed_no_tag_types, yes),
+ MaybeUserEqCmp = no,
-:- pred is_dummy_argument_type_with_constructors(type_ctor::in,
- list(constructor)::in, maybe(unify_compare)::in) is semidet.
+ type_is_single_ctor_single_arg(Ctors, SingleFunctorName, SingleArgType,
+ MaybeSingleArgName0),
-is_dummy_argument_type_with_constructors(TypeCtor, Ctors, UserEqCmp) :-
- % Keep this in sync with is_dummy_argument_type below.
- (
- is_builtin_dummy_argument_type(TypeCtor)
- ;
- constructor_list_represents_dummy_argument_type(Ctors, UserEqCmp)
- ).
+ % We don't handle unary tuples as no_tag types -- they are rare enough
+ % that it's not worth the implementation effort.
+ %
+ % XXX Since the tuple type constructor doesn't have a HLDS type defn body,
+ % will this test ever fail? Even if it can fail, we should test TypeCtor,
+ % not SingleFunctorName.
+ SingleFunctorName \= unqualified("{}"),
+
+ MaybeSingleArgName = map_maybe(unqualify_name, MaybeSingleArgName0).
%-----------------------------------------------------------------------------%
%
@@ -1409,7 +1400,6 @@
%-----------------------------------------------------------------------------%
-
apply_partial_map_to_list(_PartialMap, [], []).
apply_partial_map_to_list(PartialMap, [X | Xs], [Y | Ys]) :-
( map.search(PartialMap, X, Y0) ->
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.83
diff -u -b -r1.83 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 21 Jan 2008 00:32:53 -0000 1.83
+++ compiler/rtti_to_mlds.m 8 Feb 2008 07:59:56 -0000
@@ -892,9 +892,12 @@
gen_field_names(_ModuleInfo, RttiTypeCtor, Ordinal, MaybeNames) = MLDS_Defn :-
StrType = builtin_type(builtin_type_string),
- Init = gen_init_array(gen_init_maybe(
- mercury_type(StrType, type_cat_string, non_foreign_type(StrType)),
- gen_init_string), MaybeNames),
+ Init = gen_init_array(
+ gen_init_maybe(
+ mercury_type(StrType, ctor_cat_builtin(cat_builtin_string),
+ non_foreign_type(StrType)),
+ gen_init_string),
+ MaybeNames),
RttiName = type_ctor_field_names(Ordinal),
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.225
diff -u -b -r1.225 simplify.m
--- compiler/simplify.m 29 Jan 2008 04:59:42 -0000 1.225
+++ compiler/simplify.m 8 Feb 2008 01:06:03 -0000
@@ -1620,7 +1620,7 @@
can_switch_on_type(TypeBody) = CanSwitchOnType :-
(
TypeBody = hlds_du_type(_Ctors, _TagValues, _CheaperTagTest,
- IsEnumOrDummy, _UserEq, _ReservedTag, _ReservedAddr,
+ DuTypeKind, _UserEq, _ReservedTag, _ReservedAddr,
_MaybeForeignType),
% We don't care about _UserEq, since the unification with *any* functor
% of the type indicates that we are deconstructing the physical
@@ -1633,13 +1633,15 @@
% *any* functor of the type means that either there is no foreign type
% version, or we are using the Mercury version of the type.
(
- ( IsEnumOrDummy = is_mercury_enum
- ; IsEnumOrDummy = is_foreign_enum(_)
- ; IsEnumOrDummy = not_enum_or_dummy
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
+ ; DuTypeKind = du_type_kind_general
),
CanSwitchOnType = yes
;
- IsEnumOrDummy = is_dummy,
+ ( DuTypeKind = du_type_kind_direct_dummy
+ ; DuTypeKind = du_type_kind_notag(_, _, _)
+ ),
% We should have already got a warning that the condition cannot
% fail; a warning about using a switch would therefore be redundant
% (as well as confusing, since you cannot have a switch with one
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.70
diff -u -b -r1.70 special_pred.m
--- compiler/special_pred.m 31 Oct 2007 03:58:30 -0000 1.70
+++ compiler/special_pred.m 8 Feb 2008 08:01:39 -0000
@@ -187,13 +187,14 @@
special_pred_description(spec_pred_init, "initialisation predicate").
special_pred_is_generated_lazily(ModuleInfo, TypeCtor) :-
- TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
+ CtorCat = classify_type_ctor(ModuleInfo, TypeCtor),
(
- TypeCategory = type_cat_tuple
+ CtorCat = ctor_cat_tuple
;
- ( TypeCategory = type_cat_user_ctor
- ; TypeCategory = type_cat_enum
- ; is_introduced_type_info_type_category(TypeCategory) = yes
+ % XXX Should this succeed for cat_enum_foreign as well?
+ ( CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_enum(cat_enum_mercury)
+ ; is_introduced_type_info_type_category(CtorCat) = yes
),
module_info_get_type_table(ModuleInfo, Types),
map.search(Types, TypeCtor, TypeDefn),
@@ -211,13 +212,14 @@
Body \= hlds_solver_type(_, _),
Body \= hlds_abstract_type(solver_type),
- TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
+ CtorCat = classify_type_ctor(ModuleInfo, TypeCtor),
(
- TypeCategory = type_cat_tuple
+ CtorCat = ctor_cat_tuple
;
- ( TypeCategory = type_cat_user_ctor
- ; TypeCategory = type_cat_enum
- ; is_introduced_type_info_type_category(TypeCategory) = yes
+ % XXX Should this succeed for cat_enum_foreign as well?
+ ( CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_enum(cat_enum_mercury)
+ ; is_introduced_type_info_type_category(CtorCat) = yes
),
special_pred_is_generated_lazily_2(ModuleInfo, TypeCtor, Body, Status)
).
Index: compiler/stack_layout.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stack_layout.m,v
retrieving revision 1.139
diff -u -b -r1.139 stack_layout.m
--- compiler/stack_layout.m 23 Nov 2007 07:35:25 -0000 1.139
+++ compiler/stack_layout.m 8 Feb 2008 08:01:52 -0000
@@ -1289,7 +1289,7 @@
(
LiveValueType = live_value_var(_, _, Type, _),
get_module_info(!.Info, ModuleInfo),
- is_dummy_argument_type(ModuleInfo, Type),
+ check_dummy_type(ModuleInfo, Type) = is_dummy_type,
% We want to preserve I/O states in registers.
\+ (
Locn = locn_direct(reg(_, _))
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_gen.m,v
retrieving revision 1.107
diff -u -b -r1.107 switch_gen.m
--- compiler/switch_gen.m 30 Dec 2007 08:23:58 -0000 1.107
+++ compiler/switch_gen.m 8 Feb 2008 08:02:33 -0000
@@ -107,8 +107,8 @@
globals.lookup_bool_option(Globals, smart_indexing, Indexing),
type_to_ctor_det(VarType, VarTypeCtor),
- TypeCategory = classify_type(ModuleInfo, VarType),
- SwitchCategory = switch_util.type_cat_to_switch_cat(TypeCategory),
+ CtorCat = classify_type(ModuleInfo, VarType),
+ SwitchCategory = type_ctor_cat_to_switch_cat(CtorCat),
VarName = variable_name(!.CI, Var),
produce_variable(Var, VarCode, VarRval, !CI),
@@ -213,8 +213,8 @@
determine_switch_category(CI, Var) = SwitchCategory :-
Type = variable_type(CI, Var),
get_module_info(CI, ModuleInfo),
- classify_type(ModuleInfo, Type) = TypeCategory,
- SwitchCategory = switch_util.type_cat_to_switch_cat(TypeCategory).
+ CtorCat = classify_type(ModuleInfo, Type),
+ SwitchCategory = type_ctor_cat_to_switch_cat(CtorCat).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.40
diff -u -b -r1.40 switch_util.m
--- compiler/switch_util.m 30 Dec 2007 08:23:58 -0000 1.40
+++ compiler/switch_util.m 8 Feb 2008 03:24:37 -0000
@@ -70,9 +70,9 @@
; tag_switch
; other_switch.
- % Convert a type category to a switch category.
+ % Convert a type constructor category to a switch category.
%
-:- func type_cat_to_switch_cat(type_category) = switch_category.
+:- func type_ctor_cat_to_switch_cat(type_ctor_category) = switch_category.
% Return an estimate of the runtime cost of a constructor test for the
% given tag. We try to put the cheap tests first.
@@ -86,14 +86,14 @@
% Stuff for dense switches.
%
- % type_range(ModuleInfo, TypeCategory, Type, Min, Max, NumValues):
+ % type_range(ModuleInfo, TypeCtorCategory, Type, Min, Max, NumValues):
%
% Determine the range [Min..Max] of an atomic type, and the number of
% values in that range (including both endpoints).
% Fail if the type isn't the sort of type that has a range
% or if the type's range is too big to switch on (e.g. int).
%
-:- pred type_range(module_info::in, type_category::in, mer_type::in,
+:- pred type_range(module_info::in, type_ctor_category::in, mer_type::in,
int::out, int::out, int::out) is semidet.
% Calculate the percentage density given the range and the number of cases.
@@ -326,29 +326,36 @@
% Stuff for categorizing switches.
%
-type_cat_to_switch_cat(type_cat_enum) = atomic_switch.
-type_cat_to_switch_cat(type_cat_foreign_enum) = atomic_switch.
-type_cat_to_switch_cat(type_cat_dummy) = _ :-
- % You can't have a switch without at least two arms.
- unexpected(this_file, "type_cat_to_switch_cat: dummy").
-type_cat_to_switch_cat(type_cat_int) = atomic_switch.
-type_cat_to_switch_cat(type_cat_char) = atomic_switch.
-type_cat_to_switch_cat(type_cat_float) = other_switch.
-type_cat_to_switch_cat(type_cat_string) = string_switch.
-type_cat_to_switch_cat(type_cat_higher_order) = other_switch.
-type_cat_to_switch_cat(type_cat_user_ctor) = tag_switch.
-type_cat_to_switch_cat(type_cat_variable) = other_switch.
-type_cat_to_switch_cat(type_cat_tuple) = other_switch.
-type_cat_to_switch_cat(type_cat_void) = _ :-
- unexpected(this_file, "type_cat_to_switch_cat: void").
-type_cat_to_switch_cat(type_cat_type_info) = _ :-
- unexpected(this_file, "type_cat_to_switch_cat: type_info").
-type_cat_to_switch_cat(type_cat_type_ctor_info) = _ :-
- unexpected(this_file, "type_cat_to_switch_cat: type_ctor_info").
-type_cat_to_switch_cat(type_cat_typeclass_info) = _ :-
- unexpected(this_file, "type_cat_to_switch_cat: typeclass_info").
-type_cat_to_switch_cat(type_cat_base_typeclass_info) = _ :-
- unexpected(this_file, "type_cat_to_switch_cat: base_typeclass_info").
+type_ctor_cat_to_switch_cat(CtorCat) = SwitchCat :-
+ (
+ ( CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_char)
+ ),
+ SwitchCat = atomic_switch
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
+ SwitchCat = string_switch
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
+ SwitchCat = other_switch
+ ;
+ CtorCat = ctor_cat_user(cat_user_general),
+ SwitchCat = tag_switch
+ ;
+ ( CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_user(cat_user_direct_dummy)
+ ; CtorCat = ctor_cat_user(cat_user_notag)
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_higher_order
+ ),
+ % You can't have a switch without at least two arms, or without values
+ % that can be deconstructed.
+ unexpected(this_file, "type_ctor_cat_to_switch_cat: bad type ctor cat")
+ ).
estimate_switch_tag_test_cost(Tag) = Cost :-
(
@@ -408,9 +415,9 @@
% Stuff for dense switches.
%
-type_range(ModuleInfo, TypeCat, Type, Min, Max, NumValues) :-
+type_range(ModuleInfo, TypeCtorCat, Type, Min, Max, NumValues) :-
(
- TypeCat = type_cat_char,
+ TypeCtorCat = ctor_cat_builtin(cat_builtin_char),
% XXX The following code uses the host's character size, not the
% target's, so it won't work if cross-compiling to a machine with
% a different character size. Note also that some code in both
@@ -419,7 +426,7 @@
char.min_char_value(Min),
char.max_char_value(Max)
;
- TypeCat = type_cat_enum,
+ TypeCtorCat = ctor_cat_enum(cat_enum_mercury),
Min = 0,
type_to_ctor_det(Type, TypeCtor),
module_info_get_type_table(ModuleInfo, TypeTable),
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.144
diff -u -b -r1.144 table_gen.m
--- compiler/table_gen.m 31 Dec 2007 10:03:53 -0000 1.144
+++ compiler/table_gen.m 8 Feb 2008 08:26:05 -0000
@@ -2331,7 +2331,7 @@
varset.lookup_name(!.VarSet, Var, VarName),
ModuleInfo = !.TableInfo ^ table_module_info,
map.lookup(!.VarTypes, Var, VarType),
- classify_type(ModuleInfo, VarType) = TypeCat,
+ CtorCat = classify_type(ModuleInfo, VarType),
(
ArgMethod = arg_promise_implied,
Step = table_trie_step_promise_implied,
@@ -2342,7 +2342,7 @@
( ArgMethod = arg_value
; ArgMethod = arg_addr
),
- gen_lookup_call_for_type(ArgMethod, TypeCat, VarType, Var,
+ gen_lookup_call_for_type(ArgMethod, CtorCat, VarType, Var,
VarSeqNum, MaybeStatsRef, DebugArgStr, BackArgStr, Context,
!VarSet, !VarTypes, !TableInfo, Step, ForeignArgs,
PrefixGoals, CodeStr)
@@ -2352,15 +2352,15 @@
DebugArgStr, BackArgStr, Context, !VarSet, !VarTypes, !TableInfo,
StepDescs, RestForeignArgs, RestPrefixGoals, RestCodeStr).
-:- pred gen_lookup_call_for_type(arg_tabling_method::in, type_category::in,
- mer_type::in, prog_var::in, int::in, maybe(string)::in,
- string::in, string::in, term.context::in,
+:- pred gen_lookup_call_for_type(arg_tabling_method::in,
+ type_ctor_category::in, mer_type::in, prog_var::in, int::in,
+ maybe(string)::in, string::in, string::in, term.context::in,
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
table_info::in, table_info::out,
table_trie_step::out, list(foreign_arg)::out, list(hlds_goal)::out,
string::out) is det.
-gen_lookup_call_for_type(ArgTablingMethod0, TypeCat, Type, ArgVar, VarSeqNum,
+gen_lookup_call_for_type(ArgTablingMethod0, CtorCat, Type, ArgVar, VarSeqNum,
MaybeStatsRef, DebugArgStr, BackArgStr, Context, !VarSet, !VarTypes,
!TableInfo, Step, ExtraArgs, PrefixGoals, CodeStr) :-
ModuleInfo = !.TableInfo ^ table_module_info,
@@ -2368,11 +2368,10 @@
ForeignArg = foreign_arg(ArgVar, yes(ArgName - in_mode), Type,
native_if_possible),
(
- ( TypeCat = type_cat_enum
- ; TypeCat = type_cat_foreign_enum
- ; TypeCat = type_cat_int
- ; TypeCat = type_cat_char
- ; TypeCat = type_cat_void
+ ( CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_int)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_char)
+ ; CtorCat = ctor_cat_void
),
% Values in these type categories don't have an address.
( ArgTablingMethod0 = arg_addr ->
@@ -2381,17 +2380,14 @@
ArgTablingMethod = ArgTablingMethod0
)
;
- ( TypeCat = type_cat_string
- ; TypeCat = type_cat_float
- ; TypeCat = type_cat_type_info
- ; TypeCat = type_cat_type_ctor_info
- ; TypeCat = type_cat_higher_order
- ; TypeCat = type_cat_tuple
- ; TypeCat = type_cat_variable
- ; TypeCat = type_cat_user_ctor
- ; TypeCat = type_cat_dummy
- ; TypeCat = type_cat_typeclass_info
- ; TypeCat = type_cat_base_typeclass_info
+ ( CtorCat = ctor_cat_builtin(cat_builtin_string)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_float)
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_builtin_dummy
),
ArgTablingMethod = ArgTablingMethod0
),
@@ -2399,14 +2395,14 @@
(
ArgTablingMethod = arg_value,
(
- TypeCat = type_cat_enum,
+ CtorCat = ctor_cat_enum(cat_enum_mercury),
type_to_ctor_det(Type, TypeCtor),
module_info_get_type_table(ModuleInfo, TypeDefnTable),
map.lookup(TypeDefnTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
Ctors = TypeBody ^ du_type_ctors,
- TypeBody ^ du_type_is_enum = is_mercury_enum,
+ TypeBody ^ du_type_kind = du_type_kind_mercury_enum,
TypeBody ^ du_type_usereq = no
->
list.length(Ctors, EnumRange)
@@ -2424,38 +2420,59 @@
int_to_string(EnumRange) ++ ", " ++ ArgName ++ ", " ++
next_table_node_name ++ ");\n"
;
- (
% Mercury doesn't know the specific values of the foreign
% enums, so we cannot use an array as a trie (since we don't
% know how big the array would have to be). However, hashing
% the enum as an int will work.
- TypeCat = type_cat_foreign_enum,
+ %
+ % XXX The code of this case is the same as the code of the case
+ % shared by the builtin types below. The only reason why it is
+ % here is that switch detection cannot yet look three levels deep.
+
+ CtorCat = ctor_cat_enum(cat_enum_foreign),
CatString = "int",
- Step = table_trie_step_int
+ Step = table_trie_step_int,
+ LookupMacroName = "MR_tbl_lookup_insert_" ++ CatString,
+ PrefixGoals = [],
+ ExtraArgs = [ForeignArg],
+ LookupCodeStr = "\t" ++ LookupMacroName ++ "(" ++
+ MaybeStepStatsArgStr ++ ", " ++ DebugArgStr ++ ", " ++
+ BackArgStr ++ ", " ++ cur_table_node_name ++ ", " ++
+ ArgName ++ ", " ++ next_table_node_name ++ ");\n"
+ ;
+ % XXX The code of this case is the same as the code of the case
+ % shared by the builtin types below. The only reason why it is
+ % here is that switch detection cannot yet look three levels deep.
+
+ ( CtorCat = ctor_cat_system(cat_system_type_info)
+ ; CtorCat = ctor_cat_system(cat_system_type_ctor_info)
+ ),
+ CatString = "typeinfo",
+ Step = table_trie_step_typeinfo,
+ LookupMacroName = "MR_tbl_lookup_insert_" ++ CatString,
+ PrefixGoals = [],
+ ExtraArgs = [ForeignArg],
+ LookupCodeStr = "\t" ++ LookupMacroName ++ "(" ++
+ MaybeStepStatsArgStr ++ ", " ++ DebugArgStr ++ ", " ++
+ BackArgStr ++ ", " ++ cur_table_node_name ++ ", " ++
+ ArgName ++ ", " ++ next_table_node_name ++ ");\n"
;
- TypeCat = type_cat_int,
+ (
+ CtorCat = ctor_cat_builtin(cat_builtin_int),
CatString = "int",
Step = table_trie_step_int
;
- TypeCat = type_cat_char,
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
CatString = "char",
Step = table_trie_step_char
;
- TypeCat = type_cat_string,
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
CatString = "string",
Step = table_trie_step_string
;
- TypeCat = type_cat_float,
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
CatString = "float",
Step = table_trie_step_float
- ;
- TypeCat = type_cat_type_info,
- CatString = "typeinfo",
- Step = table_trie_step_typeinfo
- ;
- TypeCat = type_cat_type_ctor_info,
- CatString = "typeinfo",
- Step = table_trie_step_typeinfo
),
LookupMacroName = "MR_tbl_lookup_insert_" ++ CatString,
PrefixGoals = [],
@@ -2465,10 +2482,10 @@
BackArgStr ++ ", " ++ cur_table_node_name ++ ", " ++
ArgName ++ ", " ++ next_table_node_name ++ ");\n"
;
- ( TypeCat = type_cat_higher_order
- ; TypeCat = type_cat_tuple
- ; TypeCat = type_cat_variable
- ; TypeCat = type_cat_user_ctor
+ ( CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_user(_)
),
MaybeAddrString = "",
IsAddr = table_value,
@@ -2477,49 +2494,43 @@
Context, !VarSet, !VarTypes, !TableInfo, Step, ExtraArgs,
PrefixGoals, LookupCodeStr)
;
- TypeCat = type_cat_dummy,
+ CtorCat = ctor_cat_builtin_dummy,
Step = table_trie_step_dummy,
PrefixGoals = [],
ExtraArgs = [],
LookupCodeStr = "\t" ++ next_table_node_name ++ " = " ++
cur_table_node_name ++ ";\n"
;
- TypeCat = type_cat_void,
+ CtorCat = ctor_cat_void,
unexpected(this_file, "gen_lookup_call_for_type: void")
;
- TypeCat = type_cat_typeclass_info,
+ CtorCat = ctor_cat_system(cat_system_typeclass_info),
unexpected(this_file,
"gen_lookup_call_for_type: typeclass_info_type")
;
- TypeCat = type_cat_base_typeclass_info,
+ CtorCat = ctor_cat_system(cat_system_base_typeclass_info),
unexpected(this_file,
"gen_lookup_call_for_type: base_typeclass_info_type")
)
;
ArgTablingMethod = arg_addr,
(
- TypeCat = type_cat_enum,
+ CtorCat = ctor_cat_enum(_),
unexpected(this_file, "tabling enums by addr")
;
- TypeCat = type_cat_foreign_enum,
- unexpected(this_file, "tabling foreign enums by addr")
- ;
- TypeCat = type_cat_int,
+ CtorCat = ctor_cat_builtin(cat_builtin_int),
unexpected(this_file, "tabling ints by addr")
;
- TypeCat = type_cat_char,
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
unexpected(this_file, "tabling chars by addr")
;
- ( TypeCat = type_cat_string
- ; TypeCat = type_cat_float
- ; TypeCat = type_cat_type_info
- ; TypeCat = type_cat_type_ctor_info
- ; TypeCat = type_cat_typeclass_info
- ; TypeCat = type_cat_base_typeclass_info
- ; TypeCat = type_cat_higher_order
- ; TypeCat = type_cat_tuple
- ; TypeCat = type_cat_variable
- ; TypeCat = type_cat_user_ctor
+ ( CtorCat = ctor_cat_builtin(cat_builtin_string)
+ ; CtorCat = ctor_cat_builtin(cat_builtin_float)
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_user(_)
),
MaybeAddrString = "_addr",
IsAddr = table_addr,
@@ -2528,10 +2539,10 @@
Context, !VarSet, !VarTypes, !TableInfo, Step, ExtraArgs,
PrefixGoals, LookupCodeStr)
;
- TypeCat = type_cat_dummy,
+ CtorCat = ctor_cat_builtin_dummy,
unexpected(this_file, "tabling dummies by addr")
;
- TypeCat = type_cat_void,
+ CtorCat = ctor_cat_void,
unexpected(this_file, "gen_lookup_call_for_type: void")
)
;
@@ -2845,19 +2856,19 @@
NumberedVar = var_mode_pos_method(Var, _Mode, Offset, _),
ModuleInfo = !.TableInfo ^ table_module_info,
map.lookup(!.VarTypes, Var, VarType),
- classify_type(ModuleInfo, VarType) = TypeCat,
- gen_save_call_for_type(TypeCat, VarType, Var, Offset, DebugArgStr, Context,
+ CtorCat = classify_type(ModuleInfo, VarType),
+ gen_save_call_for_type(CtorCat, VarType, Var, Offset, DebugArgStr, Context,
!VarSet, !VarTypes, !TableInfo, Args, PrefixGoals, CodeStr),
generate_save_goals(NumberedRest, DebugArgStr, Context, !VarSet, !VarTypes,
!TableInfo, RestArgs, RestPrefixGoals, RestCodeStr).
-:- pred gen_save_call_for_type(type_category::in, mer_type::in,
+:- pred gen_save_call_for_type(type_ctor_category::in, mer_type::in,
prog_var::in, int::in, string::in, term.context::in,
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
table_info::in, table_info::out, list(foreign_arg)::out,
list(hlds_goal)::out, string::out) is det.
-gen_save_call_for_type(TypeCat, Type, Var, Offset, DebugArgStr, Context,
+gen_save_call_for_type(CtorCat, Type, Var, Offset, DebugArgStr, Context,
!VarSet, !VarTypes, !TableInfo, Args, PrefixGoals, CodeStr) :-
Name = arg_name(Offset),
ForeignArg = foreign_arg(Var, yes(Name - in_mode), Type,
@@ -2869,7 +2880,7 @@
CodeStr = "\t" ++ SaveMacroName ++ "(" ++ DebugArgStr ++ ", " ++
answer_block_name ++ ", " ++ int_to_string(Offset) ++ ", "
++ Name ++ ");\n"
- ; builtin_type(TypeCat) = no ->
+ ; builtin_type(CtorCat) = no ->
% If we used ForeignArg instead of GenericForeignArg, then
% Var would be unboxed when assigned to Name, which we don't want.
GenericForeignArg = foreign_arg(Var, yes(Name - in_mode),
@@ -2886,7 +2897,7 @@
answer_block_name ++ ", " ++ int_to_string(Offset) ++ ", " ++
TypeInfoName ++ ", " ++ Name ++ ");\n"
;
- type_save_category(TypeCat, CatString),
+ type_save_category(CtorCat, CatString),
SaveMacroName = "MR_tbl_save_" ++ CatString ++ "_answer",
Args = [ForeignArg],
PrefixGoals = [],
@@ -3068,27 +3079,27 @@
[Arg | Args], CodeStr ++ RestCodeStr) :-
NumberedVar = var_mode_pos_method(Var, _Mode, Offset, _),
map.lookup(!.VarTypes, Var, VarType),
- classify_type(ModuleInfo, VarType) = TypeCat,
- gen_restore_call_for_type(DebugArgStr, TypeCat, VarType, OrigInstmapDelta,
+ CtorCat = classify_type(ModuleInfo, VarType),
+ gen_restore_call_for_type(DebugArgStr, CtorCat, VarType, OrigInstmapDelta,
Var, Offset, VarInst, Arg, CodeStr),
generate_restore_goals(NumberedRest, OrigInstmapDelta, DebugArgStr,
ModuleInfo, !VarSet, !VarTypes, VarInsts, Args, RestCodeStr).
-:- pred gen_restore_call_for_type(string::in, type_category::in, mer_type::in,
- instmap_delta::in, prog_var::in, int::in,
+:- pred gen_restore_call_for_type(string::in, type_ctor_category::in,
+ mer_type::in, instmap_delta::in, prog_var::in, int::in,
pair(prog_var, mer_inst)::out, foreign_arg::out, string::out) is det.
-gen_restore_call_for_type(DebugArgStr, TypeCat, Type, OrigInstmapDelta, Var,
+gen_restore_call_for_type(DebugArgStr, CtorCat, Type, OrigInstmapDelta, Var,
Offset, Var - Inst, Arg, CodeStr) :-
Name = "restore_arg" ++ int_to_string(Offset),
( type_is_io_state(Type) ->
RestoreMacroName = "MR_tbl_restore_io_state_answer",
ArgType = Type
- ; builtin_type(TypeCat) = no ->
+ ; builtin_type(CtorCat) = no ->
RestoreMacroName = "MR_tbl_restore_any_answer",
ArgType = dummy_type_var
;
- type_save_category(TypeCat, CatString),
+ type_save_category(CtorCat, CatString),
RestoreMacroName = "MR_tbl_restore_" ++ CatString ++ "_answer",
ArgType = Type
),
@@ -3561,54 +3572,77 @@
% However, since we made type_info have arity zero, this overhead
% should be gone.
%
-:- func builtin_type(type_category) = bool.
+:- func builtin_type(type_ctor_category) = bool.
-builtin_type(type_cat_int) = yes.
-builtin_type(type_cat_char) = yes.
-builtin_type(type_cat_string) = yes.
-builtin_type(type_cat_float) = yes.
-builtin_type(type_cat_void) = yes.
-builtin_type(type_cat_type_info) = no.
-builtin_type(type_cat_type_ctor_info) = yes.
-builtin_type(type_cat_typeclass_info) = yes.
-builtin_type(type_cat_base_typeclass_info) = yes.
-builtin_type(type_cat_higher_order) = no.
-builtin_type(type_cat_enum) = no.
-builtin_type(type_cat_foreign_enum) = no.
-builtin_type(type_cat_dummy) = no.
-builtin_type(type_cat_variable) = no.
-builtin_type(type_cat_tuple) = no.
-builtin_type(type_cat_user_ctor) = no.
+builtin_type(CtorCat) = Builtin :-
+ (
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_system(cat_system_type_ctor_info)
+ ; CtorCat = ctor_cat_system(cat_system_typeclass_info)
+ ; CtorCat = ctor_cat_system(cat_system_base_typeclass_info)
+ ),
+ Builtin = yes
+ ;
+ ( CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_system(cat_system_type_info)
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_higher_order
+ ),
+ Builtin = no
+ ).
% Figure out which save and restore predicates in library/table_builtin.m
% we need to use for values of types belonging the type category given by
% the first argument. The returned value replaces CAT in
% table_save_CAT_answer and table_restore_CAT_answer.
%
-:- pred type_save_category(type_category::in, string::out) is det.
+:- pred type_save_category(type_ctor_category::in, string::out) is det.
-type_save_category(type_cat_enum, "enum").
-type_save_category(type_cat_foreign_enum, _) :-
- sorry(this_file, "tabling and foreign enumerations NYI.").
-type_save_category(type_cat_int, "int").
-type_save_category(type_cat_char, "char").
-type_save_category(type_cat_string, "string").
-type_save_category(type_cat_float, "float").
-type_save_category(type_cat_higher_order, "pred").
-type_save_category(type_cat_tuple, "any").
-type_save_category(type_cat_user_ctor, "any"). % could do better
-type_save_category(type_cat_variable, "any"). % could do better
-type_save_category(type_cat_dummy, _) :-
- unexpected(this_file, "type_save_category: dummy").
-type_save_category(type_cat_void, _) :-
- unexpected(this_file, "type_save_category: void").
-type_save_category(type_cat_type_info, "any"). % could do better
-type_save_category(type_cat_type_ctor_info, _) :-
- unexpected(this_file, "type_save_category: type_ctor_info").
-type_save_category(type_cat_typeclass_info, _) :-
- unexpected(this_file, "type_save_category: typeclass_info").
-type_save_category(type_cat_base_typeclass_info, _) :-
- unexpected(this_file, "type_save_category: base_typeclass_info").
+type_save_category(CtorCat, Name) :-
+ (
+ CtorCat = ctor_cat_enum(cat_enum_mercury),
+ Name = "enum"
+ ;
+ CtorCat = ctor_cat_enum(cat_enum_foreign),
+ sorry(this_file, "tabling and foreign enumerations NYI.")
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_int),
+ Name = "int"
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
+ Name = "float"
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
+ Name = "char"
+ ;
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
+ Name = "string"
+ ;
+ CtorCat = ctor_cat_higher_order,
+ Name = "pred"
+ ;
+ % Could do better.
+ ( CtorCat = ctor_cat_user(_)
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_system(cat_system_type_info)
+ ),
+ Name = "any"
+ ;
+ CtorCat = ctor_cat_tuple,
+ Name = "any"
+ ;
+ ( CtorCat = ctor_cat_system(cat_system_type_ctor_info)
+ ; CtorCat = ctor_cat_system(cat_system_typeclass_info)
+ ; CtorCat = ctor_cat_system(cat_system_base_typeclass_info)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_void
+ ),
+ unexpected(this_file, "type_save_category: unexpected category")
+ ).
%-----------------------------------------------------------------------------%
Index: compiler/term_constr_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_util.m,v
retrieving revision 1.13
diff -u -b -r1.13 term_constr_util.m
--- compiler/term_constr_util.m 21 Jan 2008 00:32:55 -0000 1.13
+++ compiler/term_constr_util.m 8 Feb 2008 08:26:45 -0000
@@ -286,7 +286,7 @@
;
% We don't include dummy types in the constraints - they won't tell us
% anything useful.
- is_dummy_argument_type(ModuleInfo, Type)
+ check_dummy_type(ModuleInfo, Type) = is_dummy_type
).
add_context_to_constr_termination_info(no, _, no).
Index: compiler/term_norm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_norm.m,v
retrieving revision 1.27
diff -u -b -r1.27 term_norm.m
--- compiler/term_norm.m 30 Dec 2007 08:23:59 -0000 1.27
+++ compiler/term_norm.m 8 Feb 2008 08:29:27 -0000
@@ -327,27 +327,30 @@
%-----------------------------------------------------------------------------%
zero_size_type(Module, Type) :-
- type_util.classify_type(Module, Type) = TypeCategory,
- zero_size_type_category(TypeCategory, yes).
+ CtorCat = classify_type(Module, Type),
+ zero_size_type_category(CtorCat, yes).
-:- pred zero_size_type_category(type_category::in, bool::out) is det.
+:- pred zero_size_type_category(type_ctor_category::in, bool::out) is det.
-zero_size_type_category(type_cat_int, yes).
-zero_size_type_category(type_cat_char, yes).
-zero_size_type_category(type_cat_string, yes).
-zero_size_type_category(type_cat_float, yes).
-zero_size_type_category(type_cat_void, yes).
-zero_size_type_category(type_cat_type_info, yes).
-zero_size_type_category(type_cat_type_ctor_info, yes).
-zero_size_type_category(type_cat_typeclass_info, yes).
-zero_size_type_category(type_cat_base_typeclass_info, yes).
-zero_size_type_category(type_cat_higher_order, yes).
-zero_size_type_category(type_cat_tuple, no).
-zero_size_type_category(type_cat_enum, yes).
-zero_size_type_category(type_cat_foreign_enum, yes).
-zero_size_type_category(type_cat_dummy, yes).
-zero_size_type_category(type_cat_variable, no).
-zero_size_type_category(type_cat_user_ctor, no).
+zero_size_type_category(CtorCat, ZeroSize) :-
+ (
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_user(cat_user_direct_dummy)
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ),
+ ZeroSize = yes
+ ;
+ ( CtorCat = ctor_cat_user(cat_user_notag)
+ ; CtorCat = ctor_cat_user(cat_user_general)
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_variable
+ ),
+ ZeroSize = no
+ ).
%-----------------------------------------------------------------------------%
Index: compiler/trace_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/trace_gen.m,v
retrieving revision 1.22
diff -u -b -r1.22 trace_gen.m
--- compiler/trace_gen.m 26 Nov 2007 05:13:21 -0000 1.22
+++ compiler/trace_gen.m 8 Feb 2008 08:30:22 -0000
@@ -991,9 +991,12 @@
!TVars, !VarInfos, tree(VarCode, VarsCode), !CI) :-
map.lookup(VarTypes, Var, Type),
get_module_info(!.CI, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, Type) ->
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
VarCode = empty
;
+ IsDummy = is_not_dummy_type,
trace_produce_var(Var, VarSet, InstMap, !TVars, VarInfo, VarCode, !CI),
!:VarInfos = [VarInfo | !.VarInfos]
),
@@ -1039,7 +1042,7 @@
ArgMode = top_in,
\+ inst_is_clobbered(ModuleInfo, Inst),
map.lookup(VarTypes, Var, Type),
- \+ is_dummy_argument_type(ModuleInfo, Type)
+ check_dummy_type(ModuleInfo, Type) = is_not_dummy_type
->
FailVars = [Var | FailVars0]
;
Index: compiler/trailing_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/trailing_analysis.m,v
retrieving revision 1.30
diff -u -b -r1.30 trailing_analysis.m
--- compiler/trailing_analysis.m 21 Jan 2008 00:32:55 -0000 1.30
+++ compiler/trailing_analysis.m 8 Feb 2008 06:38:48 -0000
@@ -756,35 +756,31 @@
% types and solver types may modify the trail.
Status = trail_may_modify
;
- TypeCategory = classify_type(ModuleInfo, Type),
- Status = check_type_2(ModuleInfo, Type, TypeCategory)
+ TypeCtorCategory = classify_type(ModuleInfo, Type),
+ Status = check_type_2(ModuleInfo, Type, TypeCtorCategory)
).
-:- func check_type_2(module_info, mer_type, type_category) = trailing_status.
+:- func check_type_2(module_info, mer_type, type_ctor_category)
+ = trailing_status.
-check_type_2(ModuleInfo, Type, TypeCat) = Status :-
+check_type_2(ModuleInfo, Type, TypeCtorCat) = Status :-
(
- ( TypeCat = type_cat_int
- ; TypeCat = type_cat_char
- ; TypeCat = type_cat_string
- ; TypeCat = type_cat_float
- ; TypeCat = type_cat_higher_order
- ; TypeCat = type_cat_type_info
- ; TypeCat = type_cat_type_ctor_info
- ; TypeCat = type_cat_typeclass_info
- ; TypeCat = type_cat_base_typeclass_info
- ; TypeCat = type_cat_void
- ; TypeCat = type_cat_dummy
+ ( TypeCtorCat = ctor_cat_builtin(_)
+ ; TypeCtorCat = ctor_cat_higher_order
+ ; TypeCtorCat = ctor_cat_system(_)
+ ; TypeCtorCat = ctor_cat_void
+ ; TypeCtorCat = ctor_cat_builtin_dummy
+ ; TypeCtorCat = ctor_cat_user(cat_user_direct_dummy)
),
Status = trail_will_not_modify
;
- TypeCat = type_cat_variable,
+ TypeCtorCat = ctor_cat_variable,
Status = trail_conditional
;
- ( TypeCat = type_cat_tuple
- ; TypeCat = type_cat_enum
- ; TypeCat = type_cat_foreign_enum
- ; TypeCat = type_cat_user_ctor
+ ( TypeCtorCat = ctor_cat_tuple
+ ; TypeCtorCat = ctor_cat_enum(_)
+ ; TypeCtorCat = ctor_cat_user(cat_user_notag)
+ ; TypeCtorCat = ctor_cat_user(cat_user_general)
),
type_to_ctor_and_args_det(Type, _TypeCtor, Args),
(
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.95
diff -u -b -r1.95 type_ctor_info.m
--- compiler/type_ctor_info.m 30 Dec 2007 08:24:00 -0000 1.95
+++ compiler/type_ctor_info.m 8 Feb 2008 10:46:31 -0000
@@ -288,13 +288,12 @@
rtti_data::out) is det.
construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
- TypeCtorGenInfo = type_ctor_gen_info(TypeCtor, ModuleName, TypeName,
+ TypeCtorGenInfo = type_ctor_gen_info(_TypeCtor, ModuleName, TypeName,
TypeArity, _Status, HldsDefn, UnifyPredProcId, ComparePredProcId),
make_rtti_proc_label(UnifyPredProcId, ModuleInfo, UnifyProcLabel),
make_rtti_proc_label(ComparePredProcId, ModuleInfo, CompareProcLabel),
type_to_univ(UnifyProcLabel, UnifyUniv),
type_to_univ(CompareProcLabel, CompareUniv),
- module_info_get_globals(ModuleInfo, Globals),
hlds_data.get_type_defn_body(HldsDefn, TypeBody),
Version = type_ctor_info_rtti_version,
@@ -361,7 +360,7 @@
Details = eqv(MaybePseudoTypeInfo)
;
TypeBody = hlds_du_type(Ctors, ConsTagMap, _CheaperTagTest,
- EnumDummy, MaybeUserEqComp, ReservedTag, ReservedAddr,
+ DuTypeKind, MaybeUserEqComp, ReservedTag, ReservedAddr,
_IsForeignType),
(
MaybeUserEqComp = yes(_),
@@ -371,32 +370,28 @@
EqualityAxioms = standard
),
(
- EnumDummy = is_mercury_enum,
+ DuTypeKind = du_type_kind_mercury_enum,
make_mercury_enum_details(Ctors, ConsTagMap, ReservedTag,
EqualityAxioms, Details)
;
- EnumDummy = is_foreign_enum(Lang),
+ DuTypeKind = du_type_kind_foreign_enum(Lang),
make_foreign_enum_details(Lang, Ctors, ConsTagMap, ReservedTag,
EqualityAxioms, Details)
;
- EnumDummy = is_dummy,
+ DuTypeKind = du_type_kind_direct_dummy,
make_mercury_enum_details(Ctors, ConsTagMap, ReservedTag,
EqualityAxioms, Details)
;
- EnumDummy = not_enum_or_dummy,
- (
- type_with_constructors_should_be_no_tag(Globals, TypeCtor,
- ReservedTag, Ctors, MaybeUserEqComp, Name, ArgType,
- MaybeArgName)
- ->
- make_notag_details(TypeArity, Name, ArgType, MaybeArgName,
- EqualityAxioms, Details)
+ DuTypeKind = du_type_kind_notag(FunctorName, ArgType,
+ MaybeArgName),
+ make_notag_details(TypeArity, FunctorName, ArgType,
+ MaybeArgName, EqualityAxioms, Details)
;
+ DuTypeKind = du_type_kind_general,
make_du_details(Ctors, ConsTagMap, TypeArity,
EqualityAxioms, ReservedAddr, ModuleInfo, Details)
)
)
- )
),
some [!Flags] (
!:Flags = set.init,
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.190
diff -u -b -r1.190 type_util.m
--- compiler/type_util.m 30 Jan 2008 00:46:31 -0000 1.190
+++ compiler/type_util.m 8 Feb 2008 10:32:06 -0000
@@ -118,18 +118,28 @@
%
:- pred is_existq_type(module_info::in, mer_type::in) is semidet.
- % Certain types, e.g. io.state and store.store(S), are just dummy types
- % used to ensure logical semantics; there is no need to actually pass them,
- % and so when importing or exporting procedures to/from C, we don't include
+:- type is_dummy_type
+ ---> is_dummy_type
+ ; is_not_dummy_type.
+
+ % Certain types are just dummy types used to ensure logical semantics
+ % or to act as a placeholder; they contain no information, and thus
+ % there is no need to actually pass them around, so we don't. Also,
+ % when importing or exporting procedures to/from C, we don't include
% arguments with these types.
%
- % A type is a dummy type in one of two cases: either it is a builtin
- % dummy type, or it has only a single function symbol of arity zero.
+ % A type is a dummy type in one of three cases:
%
- % Note that types that are the subject of a foreign_enum pragma cannot
- % be dummy types.
+ % - its principal type constructor is a builtin dummy type constructor
+ % such as io.state or store.store(S)
+ % - it has only a single function symbol with zero arguments,
+ % - it has only a single function symbol with one argument, which is itself
+ % a dummy type.
%
-:- pred is_dummy_argument_type(module_info::in, mer_type::in) is semidet.
+ % A type cannot be a dummy type if it is the subject of a foreign_enum
+ % pragma, or if it has a reserved tag or user defined equality.
+ %
+:- func check_dummy_type(module_info, mer_type) = is_dummy_type.
% A test for types that are defined in Mercury, but whose definitions
% are `lies', i.e. they are not sufficiently accurate for RTTI
@@ -142,11 +152,11 @@
% Given a type, determine what category its principal constructor
% falls into.
%
-:- func classify_type(module_info, mer_type) = type_category.
+:- func classify_type(module_info, mer_type) = type_ctor_category.
% Given a type_ctor, determine what sort it is.
%
-:- func classify_type_ctor(module_info, type_ctor) = type_category.
+:- func classify_type_ctor(module_info, type_ctor) = type_ctor_category.
% Report whether it is OK to include a value of the given time
% in a heap cell allocated with GC_malloc_atomic.
@@ -364,26 +374,29 @@
type_ctor_is_atomic(ModuleInfo, TypeCtor) :-
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
- type_category_is_atomic(TypeCategory) = yes.
+ type_ctor_category_is_atomic(TypeCategory) = yes.
-:- func type_category_is_atomic(type_category) = bool.
+:- func type_ctor_category_is_atomic(type_ctor_category) = bool.
-type_category_is_atomic(type_cat_int) = yes.
-type_category_is_atomic(type_cat_char) = yes.
-type_category_is_atomic(type_cat_string) = yes.
-type_category_is_atomic(type_cat_float) = yes.
-type_category_is_atomic(type_cat_higher_order) = no.
-type_category_is_atomic(type_cat_tuple) = no.
-type_category_is_atomic(type_cat_enum) = yes.
-type_category_is_atomic(type_cat_foreign_enum) = yes.
-type_category_is_atomic(type_cat_dummy) = yes.
-type_category_is_atomic(type_cat_variable) = no.
-type_category_is_atomic(type_cat_type_info) = no.
-type_category_is_atomic(type_cat_type_ctor_info) = no.
-type_category_is_atomic(type_cat_typeclass_info) = no.
-type_category_is_atomic(type_cat_base_typeclass_info) = no.
-type_category_is_atomic(type_cat_void) = yes.
-type_category_is_atomic(type_cat_user_ctor) = no.
+type_ctor_category_is_atomic(CtorCat) = IsAtomic :-
+ (
+ ( CtorCat = ctor_cat_builtin(_)
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_user(cat_user_direct_dummy)
+ ),
+ IsAtomic = yes
+ ;
+ ( CtorCat = ctor_cat_higher_order
+ ; CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_user(cat_user_notag)
+ ; CtorCat = ctor_cat_user(cat_user_general)
+ ),
+ IsAtomic = no
+ ).
type_to_type_defn(ModuleInfo, Type, TypeDefn) :-
module_info_get_type_table(ModuleInfo, TypeTable),
@@ -560,6 +573,7 @@
type_has_solver_type_details(ModuleInfo, EqvType, SolverTypeDetails)
).
+is_solver_type(ModuleInfo, Type) :-
% XXX We can't assume that type variables refer to solver types
% because otherwise the compiler will try to construct initialisation
% forwarding predicates for exported abstract types defined to be
@@ -567,7 +581,6 @@
% lead to the compiler throwing an exception. The correct solution
% is to introduce a solver typeclass, but that's something for another day.
%
-is_solver_type(ModuleInfo, Type) :-
% Type_to_type_defn_body will fail for builtin types such as `int/0'.
% Such types are not solver types so is_solver_type fails too.
% Type_to_type_defn_body also fails for type variables.
@@ -591,26 +604,56 @@
Constructor ^ cons_exist = [_ | _]
).
-is_dummy_argument_type(ModuleInfo, Type) :-
- ( type_to_ctor_and_args(Type, TypeCtor, _) ->
+check_dummy_type(ModuleInfo, Type) = IsDummy :-
+ ( type_to_ctor_and_args(Type, TypeCtor, ArgTypes) ->
% Keep this in sync with is_dummy_argument_type_with_constructors
% above.
+ IsBuiltinDummy = check_builtin_dummy_type_ctor(TypeCtor),
(
- is_builtin_dummy_argument_type(TypeCtor)
+ IsBuiltinDummy = is_builtin_dummy_type_ctor,
+ IsDummy = is_dummy_type
;
+ IsBuiltinDummy = is_not_builtin_dummy_type_ctor,
module_info_get_type_table(ModuleInfo, TypeTable),
% This can fail for some builtin type constructors such as func,
% pred, and tuple, none of which are dummy types.
- map.search(TypeTable, TypeCtor, TypeDefn),
+ ( map.search(TypeTable, TypeCtor, TypeDefn) ->
get_type_defn_body(TypeDefn, TypeBody),
- Ctors = TypeBody ^ du_type_ctors,
- UserEqCmp = TypeBody ^ du_type_usereq,
- EnumOrDummy = TypeBody ^ du_type_is_enum,
- EnumOrDummy \= is_foreign_enum(_),
- constructor_list_represents_dummy_argument_type(Ctors, UserEqCmp)
+ (
+ TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
+ (
+ DuTypeKind = du_type_kind_direct_dummy,
+ IsDummy = is_dummy_type
+ ;
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
+ ; DuTypeKind = du_type_kind_general
+ ),
+ IsDummy = is_not_dummy_type
+ ;
+ DuTypeKind = du_type_kind_notag(_, SingleArgTypeInDefn
+ , _),
+ get_type_defn_tparams(TypeDefn, TypeParams),
+ map.from_corresponding_lists(TypeParams, ArgTypes,
+ Subst),
+ apply_subst_to_type(Subst, SingleArgTypeInDefn,
+ SingleArgType),
+ IsDummy = check_dummy_type(ModuleInfo, SingleArgType)
)
;
- fail
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
+ IsDummy = is_not_dummy_type
+ )
+ ;
+ IsDummy = is_not_dummy_type
+ )
+ )
+ ;
+ IsDummy = is_not_dummy_type
).
type_ctor_has_hand_defined_rtti(Type, Body) :-
@@ -631,7 +674,7 @@
( type_to_ctor_and_args(VarType, TypeCtor, _) ->
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor)
;
- TypeCategory = type_cat_variable
+ TypeCategory = ctor_cat_variable
).
classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
@@ -641,19 +684,19 @@
Arity = 0,
(
TypeName = "character",
- TypeCategoryPrime = type_cat_char
+ TypeCategoryPrime = ctor_cat_builtin(cat_builtin_char)
;
TypeName = "int",
- TypeCategoryPrime = type_cat_int
+ TypeCategoryPrime = ctor_cat_builtin(cat_builtin_int)
;
TypeName = "float",
- TypeCategoryPrime = type_cat_float
+ TypeCategoryPrime = ctor_cat_builtin(cat_builtin_float)
;
TypeName = "string",
- TypeCategoryPrime = type_cat_string
+ TypeCategoryPrime = ctor_cat_builtin(cat_builtin_string)
;
TypeName = "void",
- TypeCategoryPrime = type_cat_void
+ TypeCategoryPrime = ctor_cat_void
)
->
TypeCategory = TypeCategoryPrime
@@ -663,39 +706,62 @@
Arity = 0,
(
TypeName = "type_info",
- TypeCategoryPrime = type_cat_type_info
+ TypeCategoryPrime = ctor_cat_system(cat_system_type_info)
;
TypeName = "type_ctor_info",
- TypeCategoryPrime = type_cat_type_ctor_info
+ TypeCategoryPrime = ctor_cat_system(cat_system_type_ctor_info)
;
TypeName = "typeclass_info",
- TypeCategoryPrime = type_cat_typeclass_info
+ TypeCategoryPrime = ctor_cat_system(cat_system_typeclass_info)
;
TypeName = "base_typeclass_info",
- TypeCategoryPrime = type_cat_base_typeclass_info
+ TypeCategoryPrime = ctor_cat_system(cat_system_base_typeclass_info)
)
->
TypeCategory = TypeCategoryPrime
;
- is_builtin_dummy_argument_type(TypeCtor)
+ check_builtin_dummy_type_ctor(TypeCtor) = is_builtin_dummy_type_ctor
->
- TypeCategory = type_cat_dummy
+ TypeCategory = ctor_cat_builtin_dummy
;
- ( type_ctor_is_higher_order(TypeCtor, _, _, _) ->
- TypeCategory = type_cat_higher_order
- ; type_ctor_is_tuple(TypeCtor) ->
- TypeCategory = type_cat_tuple
+ type_ctor_is_higher_order(TypeCtor, _, _, _)
+ ->
+ TypeCategory = ctor_cat_higher_order
+ ;
+ type_ctor_is_tuple(TypeCtor)
+ ->
+ TypeCategory = ctor_cat_tuple
;
module_info_get_type_table(ModuleInfo, TypeDefnTable),
map.lookup(TypeDefnTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- ( TypeBody ^ du_type_is_enum = is_mercury_enum ->
- TypeCategory = type_cat_enum
- ; TypeBody ^ du_type_is_enum = is_foreign_enum(_) ->
- TypeCategory = type_cat_foreign_enum
+ (
+ TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
+ (
+ DuTypeKind = du_type_kind_mercury_enum,
+ TypeCategory = ctor_cat_enum(cat_enum_mercury)
+ ;
+ DuTypeKind = du_type_kind_foreign_enum(_),
+ TypeCategory = ctor_cat_enum(cat_enum_foreign)
;
- TypeCategory = type_cat_user_ctor
+ DuTypeKind = du_type_kind_direct_dummy,
+ TypeCategory = ctor_cat_user(cat_user_direct_dummy)
+ ;
+ DuTypeKind = du_type_kind_notag(_, _, _),
+ TypeCategory = ctor_cat_user(cat_user_notag)
+ ;
+ DuTypeKind = du_type_kind_general,
+ TypeCategory = ctor_cat_user(cat_user_general)
)
+ ;
+ % XXX We should be able to return more precise descriptions
+ % than this.
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
+ TypeCategory = ctor_cat_user(cat_user_general)
)
).
@@ -713,16 +779,15 @@
type_may_use_atomic_alloc(ModuleInfo, Type) = TypeMayUseAtomic :-
TypeCategory = classify_type(ModuleInfo, Type),
(
- ( TypeCategory = type_cat_int
- ; TypeCategory = type_cat_char
- ; TypeCategory = type_cat_enum
- ; TypeCategory = type_cat_foreign_enum
- ; TypeCategory = type_cat_dummy
- ; TypeCategory = type_cat_type_ctor_info
+ ( TypeCategory = ctor_cat_builtin(cat_builtin_int)
+ ; TypeCategory = ctor_cat_builtin(cat_builtin_char)
+ ; TypeCategory = ctor_cat_enum(_)
+ ; TypeCategory = ctor_cat_builtin_dummy
+ ; TypeCategory = ctor_cat_system(cat_system_type_ctor_info)
),
TypeMayUseAtomic = may_use_atomic_alloc
;
- TypeCategory = type_cat_float,
+ TypeCategory = ctor_cat_builtin(cat_builtin_float),
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, unboxed_float, UBF),
(
@@ -733,15 +798,15 @@
TypeMayUseAtomic = may_not_use_atomic_alloc
)
;
- ( TypeCategory = type_cat_string
- ; TypeCategory = type_cat_higher_order
- ; TypeCategory = type_cat_tuple
- ; TypeCategory = type_cat_variable
- ; TypeCategory = type_cat_type_info
- ; TypeCategory = type_cat_typeclass_info
- ; TypeCategory = type_cat_base_typeclass_info
- ; TypeCategory = type_cat_void
- ; TypeCategory = type_cat_user_ctor
+ ( TypeCategory = ctor_cat_builtin(cat_builtin_string)
+ ; TypeCategory = ctor_cat_higher_order
+ ; TypeCategory = ctor_cat_tuple
+ ; TypeCategory = ctor_cat_variable
+ ; TypeCategory = ctor_cat_system(cat_system_type_info)
+ ; TypeCategory = ctor_cat_system(cat_system_typeclass_info)
+ ; TypeCategory = ctor_cat_system(cat_system_base_typeclass_info)
+ ; TypeCategory = ctor_cat_void
+ ; TypeCategory = ctor_cat_user(_) % for direct_dummy, alloc is moot
),
TypeMayUseAtomic = may_not_use_atomic_alloc
).
@@ -1014,7 +1079,7 @@
type_not_stored_in_region(Type, ModuleInfo) :-
( type_is_atomic(ModuleInfo, Type)
- ; is_dummy_argument_type(ModuleInfo, Type)
+ ; check_dummy_type(ModuleInfo, Type) = is_dummy_type
; Type = type_info_type
; Type = type_ctor_info_type
; type_is_var(Type)
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.186
diff -u -b -r1.186 unify_gen.m
--- compiler/unify_gen.m 30 Dec 2007 08:24:01 -0000 1.186
+++ compiler/unify_gen.m 8 Feb 2008 08:50:58 -0000
@@ -739,7 +739,7 @@
proc_info_arg_info(ProcInfo, ArgInfo),
VarTypes = get_var_types(!.CI),
MayUseAtomic0 = initial_may_use_atomic(ModuleInfo),
- generate_pred_args(ModuleInfo, VarTypes, Args, ArgInfo, PredArgs,
+ generate_pred_args(!.CI, VarTypes, Args, ArgInfo, PredArgs,
MayUseAtomic0, MayUseAtomic),
Vector = [
yes(ClosureLayoutRval),
@@ -759,40 +759,62 @@
generate_extra_closure_args([], _, _, empty, !CI).
generate_extra_closure_args([Var | Vars], LoopCounter, NewClosure, Code,
!CI) :-
- produce_variable(Var, Code0, Value, !CI),
- One = const(llconst_int(1)),
- Code1 = node([
- llds_instr(
- assign(field(yes(0), lval(NewClosure), lval(LoopCounter)), Value),
- "set new argument field"),
- llds_instr(assign(LoopCounter, binop(int_add, lval(LoopCounter), One)),
+ FieldLval = field(yes(0), lval(NewClosure), lval(LoopCounter)),
+ IsDummy = variable_is_of_dummy_type(!.CI, Var),
+ (
+ IsDummy = is_dummy_type,
+ ProduceCode = empty,
+ AssignCode = node([
+ llds_instr(assign(FieldLval, const(llconst_int(0))),
+ "set new argument field (dummy type)")
+ ])
+ ;
+ IsDummy = is_not_dummy_type,
+ produce_variable(Var, ProduceCode, Value, !CI),
+ AssignCode = node([
+ llds_instr(assign(FieldLval, Value),
+ "set new argument field")
+ ])
+ ),
+ IncrCode = node([
+ llds_instr(assign(LoopCounter,
+ binop(int_add, lval(LoopCounter), const(llconst_int(1)))),
"increment argument counter")
]),
- generate_extra_closure_args(Vars, LoopCounter, NewClosure, Code2, !CI),
- Code = tree_list([Code0, Code1, Code2]).
+ generate_extra_closure_args(Vars, LoopCounter, NewClosure, VarsCode, !CI),
+ Code = tree_list([ProduceCode, AssignCode, IncrCode, VarsCode]).
-:- pred generate_pred_args(module_info::in, vartypes::in, list(prog_var)::in,
+:- pred generate_pred_args(code_info::in, vartypes::in, list(prog_var)::in,
list(arg_info)::in, list(maybe(rval))::out,
may_use_atomic_alloc::in, may_use_atomic_alloc::out) is det.
generate_pred_args(_, _, [], _, [], !MayUseAtomic).
generate_pred_args(_, _, [_ | _], [], _, !MayUseAtomic) :-
unexpected(this_file, "generate_pred_args: insufficient args").
-generate_pred_args(ModuleInfo, VarTypes, [Var | Vars], [ArgInfo | ArgInfos],
- [Rval | Rvals], !MayUseAtomic) :-
+generate_pred_args(CI, VarTypes, [Var | Vars], [ArgInfo | ArgInfos],
+ [MaybeRval | MaybeRvals], !MayUseAtomic) :-
ArgInfo = arg_info(_, ArgMode),
(
ArgMode = top_in,
- Rval = yes(var(Var))
+ IsDummy = variable_is_of_dummy_type(CI, Var),
+ (
+ IsDummy = is_dummy_type,
+ Rval = const(llconst_int(0))
+ ;
+ IsDummy = is_not_dummy_type,
+ Rval = var(Var)
+ ),
+ MaybeRval = yes(Rval)
;
( ArgMode = top_out
; ArgMode = top_unused
),
- Rval = no
+ MaybeRval = no
),
map.lookup(VarTypes, Var, Type),
+ get_module_info(CI, ModuleInfo),
update_type_may_use_atomic_alloc(ModuleInfo, Type, !MayUseAtomic),
- generate_pred_args(ModuleInfo, VarTypes, Vars, ArgInfos, Rvals,
+ generate_pred_args(CI, VarTypes, Vars, ArgInfos, MaybeRvals,
!MayUseAtomic).
:- pred generate_cons_args(list(prog_var)::in, list(mer_type)::in,
@@ -1007,7 +1029,9 @@
->
VarType = variable_type(!.CI, Var),
get_module_info(!.CI, ModuleInfo),
- ( is_dummy_argument_type(ModuleInfo, VarType) ->
+ IsDummy = check_dummy_type(ModuleInfo, VarType),
+ (
+ IsDummy = is_dummy_type,
% We must handle this case specially. If we didn't, the
% generated code would copy the reference to the Var's
% current location, which may be stackvar(N) or framevar(N)
@@ -1022,6 +1046,7 @@
),
Code = empty
;
+ IsDummy = is_not_dummy_type,
ArgType = variable_type(!.CI, Arg),
generate_sub_unify(ref(Var), ref(Arg), Mode, ArgType, Code,
!CI)
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.200
diff -u -b -r1.200 unify_proc.m
--- compiler/unify_proc.m 1 Feb 2008 05:45:27 -0000 1.200
+++ compiler/unify_proc.m 8 Feb 2008 10:39:06 -0000
@@ -547,13 +547,12 @@
ConsId = cons(CtorSymName, TupleArity),
map.from_assoc_list([ConsId - single_functor_tag], ConsTagValues),
UnifyPred = no,
- IsEnum = not_enum_or_dummy,
- IsForeign = no,
+ DuTypeKind = du_type_kind_general,
ReservedTag = does_not_use_reserved_tag,
ReservedAddr = does_not_use_reserved_address,
IsForeign = no,
TypeBody = hlds_du_type([Ctor], ConsTagValues, no_cheaper_tag_test,
- IsEnum, UnifyPred, ReservedTag, ReservedAddr, IsForeign),
+ DuTypeKind, UnifyPred, ReservedTag, ReservedAddr, IsForeign),
construct_type(TypeCtor, TupleArgTypes, Type),
term.context_init(Context)
@@ -776,7 +775,7 @@
info_get_module_info(!.Info, ModuleInfo),
(
type_to_ctor_det(Type, TypeCtor),
- is_builtin_dummy_argument_type(TypeCtor)
+ check_builtin_dummy_type_ctor(TypeCtor) = is_builtin_dummy_type_ctor
->
Goal = true_goal_with_context(Context),
quantify_clause_body([X, Y], Goal, Context, Clause, !Info)
@@ -788,29 +787,34 @@
Clause, !Info)
;
(
- TypeBody = hlds_du_type(Ctors, _, _, EnumDummy, _, _, _, _),
+ TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _),
(
- ( EnumDummy = is_mercury_enum
- ; EnumDummy = is_foreign_enum(_)
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
),
make_simple_test(X, Y, umc_explicit, [], Goal),
quantify_clause_body([X, Y], Goal, Context, Clause, !Info)
;
- EnumDummy = is_dummy,
+ DuTypeKind = du_type_kind_direct_dummy,
Goal = true_goal_with_context(Context),
quantify_clause_body([X, Y], Goal, Context, Clause, !Info)
;
- EnumDummy = not_enum_or_dummy,
+ ( DuTypeKind = du_type_kind_general
+ ; DuTypeKind = du_type_kind_notag(_, _, _)
+ ),
generate_du_unify_proc_body(Ctors, X, Y, Context, Clause,
!Info)
)
;
TypeBody = hlds_eqv_type(EqvType),
- ( is_dummy_argument_type(ModuleInfo, EqvType) ->
+ IsDummyType = check_dummy_type(ModuleInfo, EqvType),
+ (
+ IsDummyType = is_dummy_type,
% Treat this type as if it were a dummy type itself.
Goal = true_goal_with_context(Context),
quantify_clause_body([X, Y], Goal, Context, Clause, !Info)
;
+ IsDummyType = is_not_dummy_type,
generate_eqv_unify_proc_body(EqvType, X, Y, Context,
Clause, !Info)
)
@@ -838,64 +842,40 @@
)
).
-:- pred generate_builtin_unify((type_category)::in, prog_var::in, prog_var::in,
- prog_context::in, clause::out,
+:- pred generate_builtin_unify(type_ctor_category::in,
+ prog_var::in, prog_var::in, prog_context::in, clause::out,
unify_proc_info::in, unify_proc_info::out) is det.
-generate_builtin_unify(TypeCategory, X, Y, Context, Clause, !Info) :-
+generate_builtin_unify(CtorCat, X, Y, Context, Clause, !Info) :-
ArgVars = [X, Y],
% can_generate_special_pred_clauses_for_type ensures the unexpected
% cases can never occur.
(
- TypeCategory = type_cat_int,
+ CtorCat = ctor_cat_builtin(cat_builtin_int),
Name = "builtin_unify_int"
;
- TypeCategory = type_cat_char,
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
Name = "builtin_unify_character"
;
- TypeCategory = type_cat_string,
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
Name = "builtin_unify_string"
;
- TypeCategory = type_cat_float,
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
Name = "builtin_unify_float"
;
- TypeCategory = type_cat_higher_order,
+ CtorCat = ctor_cat_higher_order,
Name = "builtin_unify_pred"
;
- TypeCategory = type_cat_tuple,
- unexpected(this_file, "generate_builtin_unify: tuple")
- ;
- TypeCategory = type_cat_enum,
- unexpected(this_file, "generate_builtin_unify: enum")
- ;
- TypeCategory = type_cat_foreign_enum,
- unexpected(this_file, "generate_builtin_unify: foreign enum")
- ;
- TypeCategory = type_cat_dummy,
- unexpected(this_file, "generate_builtin_unify: dummy")
- ;
- TypeCategory = type_cat_variable,
- unexpected(this_file, "generate_builtin_unify: variable type")
- ;
- TypeCategory = type_cat_type_info,
- unexpected(this_file, "generate_builtin_unify: type_info type")
- ;
- TypeCategory = type_cat_type_ctor_info,
- unexpected(this_file, "generate_builtin_unify: type_ctor_info type")
- ;
- TypeCategory = type_cat_typeclass_info,
- unexpected(this_file, "generate_builtin_unify: typeclass_info type")
- ;
- TypeCategory = type_cat_base_typeclass_info,
- unexpected(this_file,
- "generate_builtin_unify: base_typeclass_info type")
- ;
- TypeCategory = type_cat_void,
- unexpected(this_file, "generate_builtin_unify: void type")
- ;
- TypeCategory = type_cat_user_ctor,
- unexpected(this_file, "generate_builtin_unify: user_ctor type")
+ ( CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_user(_)
+ ),
+ unexpected(this_file, "generate_builtin_unify: bad ctor category")
),
build_call(Name, ArgVars, Context, UnifyGoal, !Info),
quantify_clause_body(ArgVars, UnifyGoal, Context, Clause, !Info).
@@ -997,25 +977,29 @@
"trying to create index proc for non-canonical type")
;
(
- TypeBody = hlds_du_type(Ctors, _, _, EnumDummy, _, _, _, _),
+ TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _),
(
% For enum types, the generated comparison predicate performs
% an integer comparison, and does not call the type's index
% predicate, so do not generate an index predicate for such
% types.
- EnumDummy = is_mercury_enum,
+ DuTypeKind = du_type_kind_mercury_enum,
unexpected(this_file,
"trying to create index proc for enum type")
;
- EnumDummy = is_foreign_enum(_),
+ DuTypeKind = du_type_kind_foreign_enum(_),
unexpected(this_file,
"trying to create index proc for foreign enum type")
;
- EnumDummy = is_dummy,
+ DuTypeKind = du_type_kind_direct_dummy,
unexpected(this_file,
"trying to create index proc for dummy type")
;
- EnumDummy = not_enum_or_dummy,
+ DuTypeKind = du_type_kind_notag(_, _, _),
+ unexpected(this_file,
+ "trying to create index proc for notag type")
+ ;
+ DuTypeKind = du_type_kind_general,
generate_du_index_proc_body(Ctors, X, Index, Context,
Clause, !Info)
)
@@ -1052,7 +1036,7 @@
info_get_module_info(!.Info, ModuleInfo),
(
type_to_ctor_det(Type, TypeCtor),
- is_builtin_dummy_argument_type(TypeCtor)
+ check_builtin_dummy_type_ctor(TypeCtor) = is_builtin_dummy_type_ctor
->
generate_dummy_compare_proc_body(Res, X, Y, Context, Clause, !Info)
;
@@ -1063,19 +1047,21 @@
Res, X, Y, Context, Clause, !Info)
;
(
- TypeBody = hlds_du_type(Ctors0, _, _, EnumDummy, _, _, _, _),
+ TypeBody = hlds_du_type(Ctors0, _, _, DuTypeKind, _, _, _, _),
(
- ( EnumDummy = is_mercury_enum
- ; EnumDummy = is_foreign_enum(_)
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
),
generate_enum_compare_proc_body(Res, X, Y, Context, Clause,
!Info)
;
- EnumDummy = is_dummy,
+ DuTypeKind = du_type_kind_direct_dummy,
generate_dummy_compare_proc_body(Res, X, Y, Context, Clause,
!Info)
;
- EnumDummy = not_enum_or_dummy,
+ ( DuTypeKind = du_type_kind_general
+ ; DuTypeKind = du_type_kind_notag(_, _, _)
+ ),
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals,
lexically_order_constructors, LexicalOrder),
@@ -1091,11 +1077,14 @@
)
;
TypeBody = hlds_eqv_type(EqvType),
- ( is_dummy_argument_type(ModuleInfo, EqvType) ->
+ IsDummyType = check_dummy_type(ModuleInfo, EqvType),
+ (
+ IsDummyType = is_dummy_type,
% Treat this type as if it were a dummy type itself.
generate_dummy_compare_proc_body(Res, X, Y, Context, Clause,
!Info)
;
+ IsDummyType = is_not_dummy_type,
generate_eqv_compare_proc_body(EqvType, Res, X, Y,
Context, Clause, !Info)
)
@@ -1172,64 +1161,40 @@
% XXX check me
quantify_clause_body([Res, X, Y], Goal, Context, Clause, !Info).
-:- pred generate_builtin_compare(type_category::in,
+:- pred generate_builtin_compare(type_ctor_category::in,
prog_var::in, prog_var::in, prog_var::in, prog_context::in, clause::out,
unify_proc_info::in, unify_proc_info::out) is det.
-generate_builtin_compare(TypeCategory, Res, X, Y, Context, Clause, !Info) :-
+generate_builtin_compare(CtorCat, Res, X, Y, Context, Clause, !Info) :-
ArgVars = [Res, X, Y],
% can_generate_special_pred_clauses_for_type ensures the unexpected
% cases can never occur.
(
- TypeCategory = type_cat_int,
+ CtorCat = ctor_cat_builtin(cat_builtin_int),
Name = "builtin_compare_int"
;
- TypeCategory = type_cat_char,
+ CtorCat = ctor_cat_builtin(cat_builtin_char),
Name = "builtin_compare_character"
;
- TypeCategory = type_cat_string,
+ CtorCat = ctor_cat_builtin(cat_builtin_string),
Name = "builtin_compare_string"
;
- TypeCategory = type_cat_float,
+ CtorCat = ctor_cat_builtin(cat_builtin_float),
Name = "builtin_compare_float"
;
- TypeCategory = type_cat_higher_order,
+ CtorCat = ctor_cat_higher_order,
Name = "builtin_compare_pred"
;
- TypeCategory = type_cat_tuple,
- unexpected(this_file, "generate_builtin_compare: tuple type")
- ;
- TypeCategory = type_cat_enum,
- unexpected(this_file, "generate_builtin_compare: enum type")
- ;
- TypeCategory = type_cat_foreign_enum,
- unexpected(this_file, "generate_builtin_compare: foreign enum type")
- ;
- TypeCategory = type_cat_dummy,
- unexpected(this_file, "generate_builtin_compare: dummy type")
- ;
- TypeCategory = type_cat_variable,
- unexpected(this_file, "generate_builtin_compare: variable type")
- ;
- TypeCategory = type_cat_type_info,
- unexpected(this_file, "generate_builtin_compare: type_info type")
- ;
- TypeCategory = type_cat_type_ctor_info,
- unexpected(this_file, "generate_builtin_compare: type_ctor_info type")
- ;
- TypeCategory = type_cat_typeclass_info,
- unexpected(this_file, "generate_builtin_compare: typeclass_info type")
- ;
- TypeCategory = type_cat_base_typeclass_info,
- unexpected(this_file,
- "generate_builtin_compare: base_typeclass_info type")
- ;
- TypeCategory = type_cat_void,
- unexpected(this_file, "generate_builtin_compare: void type")
- ;
- TypeCategory = type_cat_user_ctor,
- unexpected(this_file, "generate_builtin_compare: user_ctor type")
+ ( CtorCat = ctor_cat_tuple
+ ; CtorCat = ctor_cat_enum(_)
+ ; CtorCat = ctor_cat_builtin_dummy
+ ; CtorCat = ctor_cat_variable
+ ; CtorCat = ctor_cat_void
+ ; CtorCat = ctor_cat_system(_)
+ ; CtorCat = ctor_cat_user(_)
+ ),
+ unexpected(this_file, "generate_builtin_compare: bad ctor category")
),
build_call(Name, ArgVars, Context, CompareGoal, !Info),
quantify_clause_body(ArgVars, CompareGoal, Context, Clause, !Info).
@@ -1889,20 +1854,24 @@
% which would be a type error, we call `typed_compare', which is a builtin
% that first compares their types and then compares their values.
(
+ some [ExistQTVar] (
list.member(ExistQTVar, ExistQTVars),
type_contains_var(Type, ExistQTVar)
+ )
->
ComparePred = "typed_compare"
;
ComparePred = "compare"
),
- (
info_get_module_info(!.Info, ModuleInfo),
- is_dummy_argument_type(ModuleInfo, Type)
- ->
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
% X and Y contain dummy values, so there is nothing to compare.
compare_args_2(ArgTypes, ExistQTVars, Xs, Ys, R, Context, Goal, !Info)
;
+ IsDummy = is_not_dummy_type,
+ (
Xs = [],
Ys = []
->
@@ -1924,6 +1893,7 @@
Goal = hlds_goal(
if_then_else([], Condition, Return_R1, ElseCase),
GoalInfo)
+ )
).
:- pred generate_return_equal(prog_var::in, prog_context::in,
@@ -2019,13 +1989,11 @@
make_fresh_vars_from_types(ArgTypes, Vars, !Info)
;
ExistQTVars = [_ | _],
- %
% If there are existential types involved, then it's too hard to get
% the types right here (it would require allocating new type variables)
% -- instead, typecheck.m will typecheck the clause to figure out
% the correct types. So we just allocate the variables and leave it
% up to typecheck.m to infer their types.
- %
info_get_varset(!.Info, VarSet0),
list.length(CtorArgs, NumVars),
varset.new_vars(VarSet0, NumVars, Vars, VarSet),
@@ -2054,7 +2022,7 @@
term.context_init(Context),
(
info_get_module_info(!.Info, ModuleInfo),
- is_dummy_argument_type(ModuleInfo, Type)
+ check_dummy_type(ModuleInfo, Type) = is_dummy_type
->
Goal = true_goal
;
Index: compiler/var_locn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/var_locn.m,v
retrieving revision 1.57
diff -u -b -r1.57 var_locn.m
--- compiler/var_locn.m 29 Jan 2008 04:59:45 -0000 1.57
+++ compiler/var_locn.m 8 Feb 2008 08:34:23 -0000
@@ -981,9 +981,12 @@
),
var_locn_get_vartypes(!.VLI, VarTypes),
map.lookup(VarTypes, Var, Type),
- ( is_dummy_argument_type(ModuleInfo, Type) ->
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
AssignCode = empty
;
+ IsDummy = is_not_dummy_type,
add_additional_lval_for_var(Var, Target, !VLI),
get_var_name(!.VLI, Var, VarName),
Comment = "assigning from " ++ VarName,
@@ -1045,11 +1048,13 @@
),
var_locn_get_vartypes(!.VLI, VarTypes),
map.lookup(VarTypes, DepVar, DepVarType),
+ IsDummy = check_dummy_type(ModuleInfo, DepVarType),
(
- is_dummy_argument_type(ModuleInfo, DepVarType)
- ->
+ IsDummy = is_dummy_type,
AssignCode = empty
;
+ IsDummy = is_not_dummy_type,
+ (
rval_depends_on_search_lval(DepVarRval,
specific_reg_or_stack(ReuseLval))
->
@@ -1063,6 +1068,7 @@
!:Regs = [Target | !.Regs]
;
AssignCode = empty
+ )
),
SaveDepVarCode = tree(EvalCode, AssignCode).
@@ -1318,9 +1324,12 @@
),
var_locn_get_vartypes(!.VLI, VarTypes),
map.lookup(VarTypes, Var, Type),
- ( is_dummy_argument_type(ModuleInfo, Type) ->
+ IsDummy = check_dummy_type(ModuleInfo, Type),
+ (
+ IsDummy = is_dummy_type,
AssignCode = empty
;
+ IsDummy = is_not_dummy_type,
AssignCode = node([llds_instr(assign(Target, Rval), Msg)])
)
),
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/base64
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/fixed
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_allegro
cvs diff: Diffing extras/graphics/mercury_allegro/examples
cvs diff: Diffing extras/graphics/mercury_allegro/samples
cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/log4m
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/mopenssl
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/net
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/posix/samples
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/standalone_c
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/solver_types
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing ssdb
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
Index: tests/valid/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/valid/Mercury.options,v
retrieving revision 1.43
diff -u -b -r1.43 Mercury.options
--- tests/valid/Mercury.options 22 Jan 2008 13:28:55 -0000 1.43
+++ tests/valid/Mercury.options 8 Feb 2008 10:41:25 -0000
@@ -40,6 +40,7 @@
MCFLAGS-explicit_quant = --halt-at-warn
MCFLAGS-func_class = --no-warn-nothing-exported
MCFLAGS-foreign_underscore_var = --halt-at-warn
+MCFLAGS-fzn_debug_abort = --grade asm_fast.gc.debug.tr
MCFLAGS-higher_order4 = -O3
MCFLAGS-higher_order_implied_mode = -O-1
MCFLAGS-ho_and_type_spec_bug = -O4
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.205
diff -u -b -r1.205 Mmakefile
--- tests/valid/Mmakefile 22 Jan 2008 15:06:48 -0000 1.205
+++ tests/valid/Mmakefile 8 Feb 2008 10:39:59 -0000
@@ -83,9 +83,9 @@
easy_nondet_test_2 \
empty_bound_inst_list \
empty_switch \
+ equiv_solns_ia \
erl_ite_vars \
error \
- equiv_solns_ia \
eval \
existential_cons \
explicit_quant \
@@ -99,6 +99,7 @@
func_in_head \
func_int_bug_main \
fz_conf \
+ fzn_debug_abort \
hawkins_switch_bug \
headvar_not_found \
higher_order \
Index: tests/valid/fzn_debug_abort.m
===================================================================
RCS file: tests/valid/fzn_debug_abort.m
diff -N tests/valid/fzn_debug_abort.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/fzn_debug_abort.m 8 Feb 2008 09:59:35 -0000
@@ -0,0 +1,87 @@
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+%-----------------------------------------------------------------------------%
+%
+% This is a regression test for Mantis bug #44.
+%
+% rotd-2008-02-07 aborts with the following assertion failure
+%
+% Uncaught Mercury exception:
+% Software Error: llds_out.m: Unexpected: stack var out of range
+%
+% when this program is compiled in a (decl)debug grade.
+% (This test case is derived from r4597 of the G12 FlatZinc interpreter.)
+%
+%-----------------------------------------------------------------------------%
+
+:- module fzn_debug_abort.
+:- interface.
+
+:- import_module io.
+
+:- pred do_flatzinc_stages(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+:- import_module maybe.
+:- import_module string.
+:- import_module exception.
+
+%-----------------------------------------------------------------------------%
+
+do_flatzinc_stages(!IO) :-
+ MaybeItems3 = no,
+ SAT_Solver = msat,
+ do_io_stage(flatzinc_program,
+ evaluate_flatzinc_ast(flatzinc_sat_solver(SAT_Solver)),
+ MaybeItems3, _MaybeItems4, !IO).
+
+:- pred evaluate_flatzinc_ast(Solver::in, ast::in, ast::out,
+ io::di, io::uo) is det <= flatzinc_solver(Solver, Var).
+
+evaluate_flatzinc_ast(_, _, ast, !IO).
+
+:- func flatzinc_program = string.
+
+flatzinc_program = "flatzinc".
+
+%-----------------------------------------------------------------------------%
+
+:- type ast ---> ast.
+
+:- pred do_io_stage(string::in,
+ pred(A, B, io, io)::in(pred(in, out, di, uo) is det),
+ maybe(A)::in,
+ maybe(B)::out,
+ io::di, io::uo) is det.
+
+do_io_stage(_, _, _, no, !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- typeclass flatzinc_solver(Solver, Var) <= (Solver -> Var) where [].
+
+:- type flatzinc_sat_solver(S) ---> flatzinc_sat_solver(S).
+:- type flatzinc_sat_var(L) ---> flatzinc_sat_var.
+
+:- instance flatzinc_solver(flatzinc_sat_solver(S), flatzinc_sat_var(L))
+ <= clausal_sat_solver(S, L) where [].
+
+:- typeclass clausal_sat_solver(S, L) <= (S -> L) where [].
+
+%-----------------------------------------------------------------------------%
+
+:- solver type msat_literal where representation is int.
+:- type msat_solver ---> msat_solver.
+:- func msat = msat_solver.
+
+msat = msat_solver.
+
+:- instance clausal_sat_solver(msat_solver, msat_literal) where [].
+
+%-----------------------------------------------------------------------------%
+:- end_module fzn_debug_abort.
+%-----------------------------------------------------------------------------%
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list