[m-rev.] for post-commit review: fix conceptual error in tabling
Zoltan Somogyi
zs at csse.unimelb.edu.au
Wed Aug 15 11:32:00 AEST 2007
Fix the warning we used to get in hlc grades when tabling tuples, and fix
the conceptual error that caused the problem.
compiler/hlds_pred.m:
library/table_builtin.m:
runtime/mercury_tabling.h:
In descriptions of tabling trie steps, replace references to
"user" (as in user-defined types) with "gen" (general types),
since these are also used for other kinds of types, such as tuples
and higher order types.
library/table_builtin.m:
runtime/mercury_tabling_macros.h:
runtime/mercury_tabling_preds.h:
Adopt a more consistent naming scheme for these tabling trie steps,
and for the Mercury predicates and C macros that operate on them.
In table_builtin.m, add a missing Mercury clause for a predicate
usually defined in C.
In mercury_tabling_macros, parameterize the diagnostic message when
doing a lookup step on a general type.
In mercury_tabling_preds, cast general value types to MR_Word,
since they can be some other type originally (e.g. if the general type
value is a tuple).
compiler/table_gen.m:
Conform to the changes above, and switch to using a single nested
switch for generating the lookup code of each step.
compiler/hlds_out.m:
runtime/mercury_table_body.h:
Conform to the changes above.
tests/tabling/expand_tuple2.{m,exp}:
New test case to test tabling of values statically known to be tries.
(The old expand_tuple test case tested tabling polymorphic values in
which the type variable was bound to a tuple, which is not the same
thing.)
tests/tabling/Mmakefile:
Enable the next test case.
Zoltan.
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/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.430
diff -u -b -r1.430 hlds_out.m
--- compiler/hlds_out.m 13 Aug 2007 03:01:40 -0000 1.430
+++ compiler/hlds_out.m 14 Aug 2007 05:31:45 -0000
@@ -279,6 +279,7 @@
:- import_module set.
:- import_module string.
:- import_module term_io.
+:- import_module table_builtin.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -4039,12 +4040,24 @@
table_trie_step_desc(_, table_trie_step_dummy) = "dummy".
table_trie_step_desc(_, table_trie_step_enum(N)) =
"enum(" ++ int_to_string(N) ++ ")".
-table_trie_step_desc(TVarSet, table_trie_step_user(Type)) =
- "user(" ++ mercury_type_to_string(TVarSet, yes, Type) ++ ")".
-table_trie_step_desc(TVarSet, table_trie_step_user_fast_loose(Type)) =
- "user_fast_loose(" ++ mercury_type_to_string(TVarSet, yes, Type) ++ ")".
-table_trie_step_desc(_, table_trie_step_poly) = "poly".
-table_trie_step_desc(_, table_trie_step_poly_fast_loose) = "poly_fast_loose".
+table_trie_step_desc(TVarSet, table_trie_step_general(Type, IsPoly, IsAddr)) =
+ Str :-
+ (
+ IsPoly = table_is_poly,
+ IsPolyStr = "poly"
+ ;
+ IsPoly = table_is_mono,
+ IsPolyStr = "mono"
+ ),
+ (
+ IsAddr = table_value,
+ IsAddrStr = "value"
+ ;
+ IsAddr = table_addr,
+ IsAddrStr = "addr"
+ ),
+ Str = "general(" ++ mercury_type_to_string(TVarSet, yes, Type) ++ ", " ++
+ IsPolyStr ++ ", " ++ IsAddrStr ++ ")".
table_trie_step_desc(_, table_trie_step_typeinfo) = "typeinfo".
table_trie_step_desc(_, table_trie_step_typeclassinfo) = "typeclassinfo".
table_trie_step_desc(_, table_trie_step_promise_implied) = "promise_implied".
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.230
diff -u -b -r1.230 hlds_pred.m
--- compiler/hlds_pred.m 13 Aug 2007 03:01:41 -0000 1.230
+++ compiler/hlds_pred.m 14 Aug 2007 05:12:21 -0000
@@ -43,6 +43,7 @@
:- import_module maybe.
:- import_module pair.
:- import_module set.
+:- import_module table_builtin.
:- implementation.
@@ -1738,13 +1739,16 @@
; table_trie_step_string
; table_trie_step_float
; table_trie_step_dummy
- ; table_trie_step_enum(int)
+ ; table_trie_step_enum(
% The int gives the number of alternatives in the enum type,
% and thus the size of the corresponding trie node.
- ; table_trie_step_user(mer_type)
- ; table_trie_step_user_fast_loose(mer_type)
- ; table_trie_step_poly
- ; table_trie_step_poly_fast_loose
+ int
+ )
+ ; table_trie_step_general(
+ mer_type,
+ table_is_poly,
+ table_value_or_addr
+ )
; table_trie_step_typeinfo
; table_trie_step_typeclassinfo
; table_trie_step_promise_implied.
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.83
diff -u -b -r1.83 rtti.m
--- compiler/rtti.m 13 Aug 2007 03:01:43 -0000 1.83
+++ compiler/rtti.m 14 Aug 2007 07:09:42 -0000
@@ -941,6 +941,7 @@
:- import_module int.
:- import_module pair.
:- import_module string.
+:- import_module table_builtin.
:- import_module varset.
%----------------------------------------------------------------------------%
@@ -2086,12 +2087,14 @@
table_trie_step_to_c(table_trie_step_float, "MR_TABLE_STEP_FLOAT", no).
table_trie_step_to_c(table_trie_step_enum(EnumRange), "MR_TABLE_STEP_ENUM",
yes(EnumRange)).
-table_trie_step_to_c(table_trie_step_user(_), "MR_TABLE_STEP_USER", no).
-table_trie_step_to_c(table_trie_step_user_fast_loose(_),
- "MR_TABLE_STEP_USER_FAST_LOOSE", no).
-table_trie_step_to_c(table_trie_step_poly, "MR_TABLE_STEP_POLY", no).
-table_trie_step_to_c(table_trie_step_poly_fast_loose,
- "MR_TABLE_STEP_POLY_FAST_LOOSE", no).
+table_trie_step_to_c(table_trie_step_general(_, table_is_mono, table_value),
+ "MR_TABLE_STEP_GEN", no).
+table_trie_step_to_c(table_trie_step_general(_, table_is_poly, table_value),
+ "MR_TABLE_STEP_GEN_POLY", no).
+table_trie_step_to_c(table_trie_step_general(_, table_is_mono, table_addr),
+ "MR_TABLE_STEP_GEN_ADDR", no).
+table_trie_step_to_c(table_trie_step_general(_, table_is_poly, table_addr),
+ "MR_TABLE_STEP_GEN_POLY_ADDR", no).
table_trie_step_to_c(table_trie_step_typeinfo, "MR_TABLE_STEP_TYPEINFO", no).
table_trie_step_to_c(table_trie_step_typeclassinfo,
"MR_TABLE_STEP_TYPECLASSINFO", no).
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.135
diff -u -b -r1.135 table_gen.m
--- compiler/table_gen.m 13 Aug 2007 03:01:44 -0000 1.135
+++ compiler/table_gen.m 14 Aug 2007 07:13:40 -0000
@@ -87,6 +87,7 @@
:- import_module set.
:- import_module solutions.
:- import_module string.
+:- import_module table_builtin.
:- import_module term.
:- import_module unit.
:- import_module varset.
@@ -2341,16 +2342,16 @@
table_trie_step::out, list(foreign_arg)::out, list(hlds_goal)::out,
string::out) is det.
-gen_lookup_call_for_type(ArgTablingMethod, TypeCat, Type, ArgVar,
- VarSeqNum, Statistics, Kind, DebugArgStr, BackArgStr, Context,
- !VarSet, !VarTypes, !TableInfo, Step, ExtraArgs, PrefixGoals,
- CodeStr) :-
+gen_lookup_call_for_type(ArgTablingMethod, TypeCat, Type, ArgVar, VarSeqNum,
+ Statistics, Kind, DebugArgStr, BackArgStr, Context, !VarSet, !VarTypes,
+ !TableInfo, Step, ExtraArgs, PrefixGoals, CodeStr) :-
ModuleInfo = !.TableInfo ^ table_module_info,
ArgName = arg_name(VarSeqNum),
ForeignArg = foreign_arg(ArgVar, yes(ArgName - in_mode), Type,
native_if_possible),
- ( TypeCat = type_cat_enum ->
- ( type_to_ctor_and_args(Type, TypeCtor, _) ->
+ (
+ TypeCat = type_cat_enum,
+ 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),
@@ -2374,54 +2375,81 @@
cur_table_node_name ++ ", " ++ int_to_string(EnumRange) ++
", " ++ ArgName ++ ", " ++ next_table_node_name ++ ");\n"
;
- unexpected(this_file,
- "gen_lookup_call_for_type: unexpected enum type")
- )
- ; TypeCat = type_cat_dummy ->
- Step = table_trie_step_dummy,
+ (
+ TypeCat = type_cat_int,
+ CatString = "int",
+ Step = table_trie_step_int
+ ;
+ TypeCat = type_cat_char,
+ CatString = "char",
+ Step = table_trie_step_char
+ ;
+ TypeCat = type_cat_string,
+ CatString = "string",
+ Step = table_trie_step_string
+ ;
+ TypeCat = type_cat_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 = [],
- ExtraArgs = [],
- CodeStr0 = next_table_node_name ++ " = "
- ++ cur_table_node_name ++ ";\n "
+ ExtraArgs = [ForeignArg],
+ StatsArgStr = stats_arg(Statistics, Kind, VarSeqNum),
+ CodeStr0 = "\t" ++ LookupMacroName ++ "(" ++ StatsArgStr ++ ", " ++
+ DebugArgStr ++ ", " ++ BackArgStr ++ ", " ++
+ cur_table_node_name ++ ", " ++ ArgName ++ ", " ++
+ next_table_node_name ++ ");\n"
;
- lookup_tabling_category(TypeCat, MaybeCatStringStep),
(
- MaybeCatStringStep = no,
+ TypeCat = type_cat_higher_order
+ ;
+ TypeCat = type_cat_tuple
+ ;
+ TypeCat = type_cat_variable
+ ;
+ TypeCat = type_cat_user_ctor
+ ),
type_vars(Type, TypeVars),
(
- ArgTablingMethod = arg_value,
- (
TypeVars = [],
- LookupMacroName = "MR_tbl_lookup_insert_user",
- Step = table_trie_step_user(Type)
+ MaybePolyString = "",
+ IsPoly = table_is_mono
;
TypeVars = [_ | _],
- LookupMacroName = "MR_tbl_lookup_insert_poly",
- Step = table_trie_step_poly
- )
- ;
- ArgTablingMethod = arg_addr,
+ MaybePolyString = "_poly",
+ IsPoly = table_is_poly
+ ),
(
- TypeVars = [],
- LookupMacroName = "MR_tbl_lookup_insert_user_addr",
- Step = table_trie_step_user_fast_loose(Type)
+ ArgTablingMethod = arg_value,
+ MaybeAddrString = "",
+ IsAddr = table_value
;
- TypeVars = [_ | _],
- LookupMacroName = "MR_tbl_lookup_insert_poly_addr",
- Step = table_trie_step_poly_fast_loose
- )
+ ArgTablingMethod = arg_addr,
+ MaybeAddrString = "_addr",
+ IsAddr = table_addr
;
ArgTablingMethod = arg_promise_implied,
unexpected(this_file,
"gen_lookup_call_for_type: arg_promise_implied")
),
+ Step = table_trie_step_general(Type, IsPoly, IsAddr),
+ LookupMacroName = "MR_tbl_lookup_insert_gen" ++
+ MaybePolyString ++ MaybeAddrString,
table_gen_make_type_info_var(Type, Context, !VarSet, !VarTypes,
!TableInfo, TypeInfoVar, PrefixGoals),
TypeInfoArgName = "input_typeinfo" ++ int_to_string(VarSeqNum),
map.lookup(!.VarTypes, TypeInfoVar, TypeInfoType),
ForeignTypeInfoArg = foreign_arg(TypeInfoVar,
- yes(TypeInfoArgName - in_mode), TypeInfoType,
- native_if_possible),
+ yes(TypeInfoArgName - in_mode), TypeInfoType, native_if_possible),
ExtraArgs = [ForeignTypeInfoArg, ForeignArg],
StatsArgStr = stats_arg(Statistics, Kind, VarSeqNum),
CodeStr0 = "\t" ++ LookupMacroName ++ "(" ++ StatsArgStr ++ ", " ++
@@ -2429,16 +2457,22 @@
cur_table_node_name ++ ", " ++ TypeInfoArgName ++ ", " ++
ArgName ++ ", " ++ next_table_node_name ++ ");\n"
;
- MaybeCatStringStep = yes(CatString - Step),
- LookupMacroName = "MR_tbl_lookup_insert_" ++ CatString,
+ TypeCat = type_cat_dummy,
+ Step = table_trie_step_dummy,
PrefixGoals = [],
- ExtraArgs = [ForeignArg],
- StatsArgStr = stats_arg(Statistics, Kind, VarSeqNum),
- CodeStr0 = "\t" ++ LookupMacroName ++ "(" ++ StatsArgStr ++ ", " ++
- DebugArgStr ++ ", " ++ BackArgStr ++ ", " ++
- cur_table_node_name ++ ", " ++ ArgName ++ ", " ++
- next_table_node_name ++ ");\n"
- )
+ ExtraArgs = [],
+ CodeStr0 = "\t" ++ next_table_node_name ++ " = " ++
+ cur_table_node_name ++ ";\n"
+ ;
+ TypeCat = type_cat_void,
+ unexpected(this_file, "gen_lookup_call_for_type: void")
+ ;
+ TypeCat = type_cat_typeclass_info,
+ unexpected(this_file, "gen_lookup_call_for_type: typeclass_info_type")
+ ;
+ TypeCat = type_cat_base_typeclass_info,
+ unexpected(this_file,
+ "gen_lookup_call_for_type: base_typeclass_info_type")
),
CodeStr = CodeStr0 ++ "\t" ++ cur_table_node_name ++ " = " ++
next_table_node_name ++ ";\n".
@@ -3402,38 +3436,6 @@
builtin_type(type_cat_tuple) = no.
builtin_type(type_cat_user_ctor) = no.
- % Figure out what kind of data structure implements the lookup table
- % for values of a given builtin type.
- %
-:- pred lookup_tabling_category(type_category::in,
- maybe(pair(string, table_trie_step))::out) is det.
-
-lookup_tabling_category(type_cat_int,
- yes("int" - table_trie_step_int)).
-lookup_tabling_category(type_cat_char,
- yes("char" - table_trie_step_char)).
-lookup_tabling_category(type_cat_string,
- yes("string" - table_trie_step_string)).
-lookup_tabling_category(type_cat_float,
- yes("float" - table_trie_step_float)).
-lookup_tabling_category(type_cat_void, _) :-
- unexpected(this_file, "lookup_tabling_category: void").
-lookup_tabling_category(type_cat_dummy, _) :-
- unexpected(this_file, "lookup_tabling_category: dummy_type").
-lookup_tabling_category(type_cat_type_info,
- yes("typeinfo" - table_trie_step_typeinfo)).
-lookup_tabling_category(type_cat_type_ctor_info,
- yes("typeinfo" - table_trie_step_typeinfo)).
-lookup_tabling_category(type_cat_typeclass_info, _) :-
- unexpected(this_file, "lookup_tabling_category: typeclass_info_type").
-lookup_tabling_category(type_cat_base_typeclass_info, _) :-
- unexpected(this_file, "lookup_tabling_category: base_typeclass_info_type").
-lookup_tabling_category(type_cat_enum, no).
-lookup_tabling_category(type_cat_higher_order, no).
-lookup_tabling_category(type_cat_tuple, no).
-lookup_tabling_category(type_cat_variable, no).
-lookup_tabling_category(type_cat_user_ctor, 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
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
Index: library/table_builtin.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/table_builtin.m,v
retrieving revision 1.61
diff -u -b -r1.61 table_builtin.m
--- library/table_builtin.m 12 Jul 2007 03:04:16 -0000 1.61
+++ library/table_builtin.m 14 Aug 2007 06:06:15 -0000
@@ -137,6 +137,9 @@
step_statistics :: list(table_step_stats)
).
+ % The definition of this type should be kept in sync with the type
+ % table_trie_step in hlds_pred.m.
+ % MR_TableTrieStep in runtime/mercury_tabling.h.
:- type table_step_kind
---> table_step_dummy
; table_step_int
@@ -144,14 +147,22 @@
; table_step_string
; table_step_float
; table_step_enum
- ; table_step_user
- ; table_step_user_fast_loose
- ; table_step_poly
- ; table_step_poly_fast_loose
+ ; table_step_general(
+ table_is_poly,
+ table_value_or_addr
+ )
; table_step_typeinfo
; table_step_typeclassinfo
; table_step_promise_implied.
+:- type table_is_poly
+ ---> table_is_poly % The table type is polymorphic.
+ ; table_is_mono. % The table type is monomorphic.
+
+:- type table_value_or_addr
+ ---> table_value % We are tabling the value itself.
+ ; table_addr. % We are tabling only the address.
+
:- type table_step_stats
---> table_step_stats(
table_step_kind :: table_step_kind,
@@ -1559,33 +1570,35 @@
:- impure pred table_lookup_insert_float(ml_trie_node::in, float::in,
ml_trie_node::out) is det.
- % Lookup or inert an enumeration type in the given trie.
+ % Lookup or insert an enumeration type in the given trie.
%
:- impure pred table_lookup_insert_enum(ml_trie_node::in, int::in, T::in,
ml_trie_node::out) is det.
- % Lookup or insert a monomorphic user defined type in the given trie.
+ % Lookup or insert a monomorphic general type in the given trie.
%
-:- impure pred table_lookup_insert_user(ml_trie_node::in, T::in,
+:- impure pred table_lookup_insert_gen(ml_trie_node::in, T::in,
ml_trie_node::out) is det.
- % Lookup or insert a monomorphic user defined type in the given trie,
+ % Lookup or insert a monomorphic general type in the given trie,
% tabling terms without traversing them. This makes the operation fast,
% but if a term was inserted previously, we will catch it only if the
% insert was the exact same memory cells. (This is the "loose" part.)
-:- impure pred table_lookup_insert_user_fast_loose(ml_trie_node::in, T::in,
+ %
+:- impure pred table_lookup_insert_gen_addr(ml_trie_node::in, T::in,
ml_trie_node::out) is det.
- % Lookup or insert a polymorphic user defined type in the given trie.
+ % Lookup or insert a polymorphic general type in the given trie.
%
-:- impure pred table_lookup_insert_poly(ml_trie_node::in, T::in,
+:- impure pred table_lookup_insert_gen_poly(ml_trie_node::in, T::in,
ml_trie_node::out) is det.
- % Lookup or insert a polymorphic user defined type in the given trie,
+ % Lookup or insert a polymorphic general type in the given trie,
% tabling terms without traversing them. This makes the operation fast,
% but if a term was inserted previously, we will catch it only if the
% insert was the exact same memory cells. (This is the "loose" part.)
-:- impure pred table_lookup_insert_poly_fast_loose(ml_trie_node::in, T::in,
+ %
+:- impure pred table_lookup_insert_gen_poly_addr(ml_trie_node::in, T::in,
ml_trie_node::out) is det.
% Lookup or insert a type_info in the given trie.
@@ -1740,50 +1753,51 @@
").
:- pragma foreign_proc("C",
- table_lookup_insert_user(T0::in, V::in, T::out),
+ table_lookup_insert_gen(T0::in, V::in, T::out),
[will_not_call_mercury, does_not_affect_liveness],
"
- MR_tbl_lookup_insert_user(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE, T0,
+ MR_tbl_lookup_insert_gen(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE, T0,
TypeInfo_for_T, V, T);
").
:- pragma foreign_proc("C",
- table_lookup_insert_user_fast_loose(T0::in, V::in, T::out),
+ table_lookup_insert_gen_addr(T0::in, V::in, T::out),
[will_not_call_mercury, does_not_affect_liveness],
"
- MR_tbl_lookup_insert_user_addr(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE, T0,
+ MR_tbl_lookup_insert_gen_addr(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE, T0,
TypeInfo_for_T, V, T);
").
:- pragma foreign_proc("C",
- table_lookup_insert_poly(T0::in, V::in, T::out),
+ table_lookup_insert_gen_poly(T0::in, V::in, T::out),
[will_not_call_mercury, does_not_affect_liveness],
"
- MR_tbl_lookup_insert_poly(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE, T0,
+ MR_tbl_lookup_insert_gen_poly(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE, T0,
TypeInfo_for_T, V, T);
").
:- pragma foreign_proc("C",
- table_lookup_insert_poly_fast_loose(T0::in, V::in, T::out),
+ table_lookup_insert_gen_poly_addr(T0::in, V::in, T::out),
[will_not_call_mercury, does_not_affect_liveness],
"
- MR_tbl_lookup_insert_poly_addr(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE, T0,
- TypeInfo_for_T, V, T);
+ MR_tbl_lookup_insert_gen_poly_addr(NULL, MR_TABLE_DEBUG_BOOL,
+ MR_FALSE, T0, TypeInfo_for_T, V, T);
").
:- pragma foreign_proc("C",
table_lookup_insert_typeinfo(T0::in, V::in, T::out),
[will_not_call_mercury, does_not_affect_liveness],
"
- MR_tbl_lookup_insert_typeinfo(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE, T0, V, T);
+ MR_tbl_lookup_insert_typeinfo(NULL, MR_TABLE_DEBUG_BOOL,
+ MR_FALSE, T0, V, T);
").
:- pragma foreign_proc("C",
table_lookup_insert_typeclassinfo(T0::in, V::in, T::out),
[will_not_call_mercury, does_not_affect_liveness],
"
- MR_tbl_lookup_insert_typeclassinfo(NULL, MR_TABLE_DEBUG_BOOL, MR_FALSE,
- T0, V, T);
+ MR_tbl_lookup_insert_typeclassinfo(NULL, MR_TABLE_DEBUG_BOOL,
+ MR_FALSE, T0, V, T);
").
%-----------------------------------------------------------------------------%
@@ -1919,17 +1933,29 @@
impure private_builtin.imp,
private_builtin.sorry("table_lookup_insert_enum").
-table_lookup_insert_user(_, _, _) :-
+table_lookup_insert_gen(_, _, _) :-
+ % This version is only used for back-ends for which there is no
+ % matching foreign_proc version.
+ impure private_builtin.imp,
+ private_builtin.sorry("table_lookup_insert_gen").
+
+table_lookup_insert_gen_poly(_, _, _) :-
+ % This version is only used for back-ends for which there is no
+ % matching foreign_proc version.
+ impure private_builtin.imp,
+ private_builtin.sorry("table_lookup_insert_gen_poly").
+
+table_lookup_insert_gen_addr(_, _, _) :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
impure private_builtin.imp,
- private_builtin.sorry("table_lookup_insert_user").
+ private_builtin.sorry("table_lookup_insert_gen_addr").
-table_lookup_insert_poly(_, _, _) :-
+table_lookup_insert_gen_poly_addr(_, _, _) :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
impure private_builtin.imp,
- private_builtin.sorry("table_lookup_insert_poly").
+ private_builtin.sorry("table_lookup_insert_gen_poly_addr").
table_save_int_answer(_, _, _) :-
% This version is only used for back-ends for which there is no
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/mercury_table_type_body.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_table_type_body.h,v
retrieving revision 1.4
diff -u -b -r1.4 mercury_table_type_body.h
--- runtime/mercury_table_type_body.h 13 Feb 2007 01:58:57 -0000 1.4
+++ runtime/mercury_table_type_body.h 14 Aug 2007 00:20:26 -0000
@@ -209,7 +209,8 @@
functor_desc->MR_du_functor_arg_types[i]);
}
- MR_TABLE_ANY(STATS, DEBUG, BACK, table_next, table,
+ MR_TABLE_ANY(STATS, DEBUG, BACK, "du arg",
+ table_next, table,
arg_type_info, arg_vector[meta_args + i]);
table = table_next;
}
@@ -228,8 +229,8 @@
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
MR_type_ctor_layout(type_ctor_info).MR_layout_notag->
MR_notag_functor_arg_type, &allocated_memory_cells);
- MR_TABLE_ANY(STATS, DEBUG, BACK, table_next, table,
- eqv_type_info, data);
+ MR_TABLE_ANY(STATS, DEBUG, BACK, "notag arg",
+ table_next, table, eqv_type_info, data);
table = table_next;
MR_deallocate(allocated_memory_cells);
}
@@ -237,7 +238,8 @@
case MR_TYPECTOR_REP_NOTAG_GROUND:
case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- MR_TABLE_ANY(STATS, DEBUG, BACK, table_next, table,
+ MR_TABLE_ANY(STATS, DEBUG, BACK, "notag ground arg",
+ table_next, table,
MR_pseudo_type_info_is_ground(
MR_type_ctor_layout(type_ctor_info).MR_layout_notag->
MR_notag_functor_arg_type), data);
@@ -253,7 +255,7 @@
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv,
&allocated_memory_cells);
- MR_TABLE_ANY(STATS, DEBUG, BACK, table_next, table,
+ MR_TABLE_ANY(STATS, DEBUG, BACK, "equiv", table_next, table,
eqv_type_info, data);
table = table_next;
MR_deallocate(allocated_memory_cells);
@@ -262,7 +264,7 @@
return table;
case MR_TYPECTOR_REP_EQUIV_GROUND:
- MR_TABLE_ANY(STATS, DEBUG, BACK, table_next, table,
+ MR_TABLE_ANY(STATS, DEBUG, BACK, "equiv ground", table_next, table,
MR_pseudo_type_info_is_ground(
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv),
data);
@@ -315,7 +317,8 @@
closure->MR_closure_code);
table = table_next;
for (i = 1; i <= num_hidden_args; i++) {
- MR_TABLE_ANY(STATS, DEBUG, BACK, table_next, table,
+ MR_TABLE_ANY(STATS, DEBUG, BACK, "closure arg",
+ table_next, table,
<type_info for hidden closure argument number i>,
closure->MR_closure_hidden_args(i));
table = table_next;
@@ -346,7 +349,8 @@
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info);
for (i = 0; i < arity; i++) {
/* type_infos are counted starting at one */
- MR_TABLE_ANY(STATS, DEBUG, BACK, table_next, table,
+ MR_TABLE_ANY(STATS, DEBUG, BACK, "tuple arg",
+ table_next, table,
arg_type_info_vector[i + 1], data_value[i]);
table = table_next;
}
@@ -421,8 +425,8 @@
(MR_PseudoTypeInfo) 1, &allocated_memory_cells);
for (i = 0; i < array_size; i++) {
- MR_TABLE_ANY(STATS, DEBUG, BACK, table_next, table,
- new_type_info, array->elements[i]);
+ MR_TABLE_ANY(STATS, DEBUG, BACK, "array element",
+ table_next, table, new_type_info, array->elements[i]);
table = table_next;
}
Index: runtime/mercury_tabling.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_tabling.h,v
retrieving revision 1.43
diff -u -b -r1.43 mercury_tabling.h
--- runtime/mercury_tabling.h 13 Feb 2007 01:58:58 -0000 1.43
+++ runtime/mercury_tabling.h 14 Aug 2007 06:02:39 -0000
@@ -248,10 +248,10 @@
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_STRING),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_FLOAT),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_ENUM),
- MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_USER),
- MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_USER_FAST_LOOSE),
- MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_POLY),
- MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_POLY_FAST_LOOSE),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_GEN),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_GEN_ADDR),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_GEN_POLY),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_GEN_POLY_ADDR),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_TYPEINFO),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_TYPECLASSINFO),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_TABLE_STEP_PROMISE_IMPLIED)
Index: runtime/mercury_tabling_macros.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_tabling_macros.h,v
retrieving revision 1.15
diff -u -b -r1.15 mercury_tabling_macros.h
--- runtime/mercury_tabling_macros.h 13 Feb 2007 01:58:59 -0000 1.15
+++ runtime/mercury_tabling_macros.h 14 Aug 2007 00:12:35 -0000
@@ -1,5 +1,5 @@
/*
-** vim: ts=4 sw=4
+** vim: ts=4 sw=4 et
*/
/*
** Copyright (C) 1997-2000,2002-2007 The University of Melbourne.
@@ -108,7 +108,7 @@
/***********************************************************************/
-#define MR_TABLE_ANY(stats, debug, back, t, t0, type_info, value) \
+#define MR_TABLE_ANY(stats, debug, back, kind, t, t0, type_info, value) \
do { \
if (stats != NULL) { \
(t) = MR_RAW_TABLE_ANY_STATS((stats), (t0), \
@@ -117,12 +117,12 @@
(t) = MR_RAW_TABLE_ANY((t0), (type_info), (value)); \
} \
if (debug && MR_tabledebug) { \
- printf("TABLE %p: any %lx type %p => %p\n", \
- (t0), (long) (value), (type_info), (t)); \
+ printf("TABLE %p: %s %lx type %p => %p\n", \
+ (t0), (kind), (long) (value), (type_info), (t)); \
} \
} while (0)
-#define MR_TABLE_ANY_ADDR(stats, debug, back, t, t0, type_info, value) \
+#define MR_TABLE_ANY_ADDR(stats, debug, back, kind, t, t0, type_info, value)\
do { \
if (stats != NULL) { \
(t) = MR_RAW_TABLE_ANY_ADDR_STATS((stats), (t0), \
@@ -131,8 +131,8 @@
(t) = MR_RAW_TABLE_ANY_ADDR((t0), (type_info), (value)); \
} \
if (debug && MR_tabledebug) { \
- printf("TABLE %p: any %lx type %p => %p\n", \
- (t0), (long) (value), (type_info), (t)); \
+ printf("TABLE %p: %s %lx type %p => %p\n", \
+ (t0), (kind), (long) (value), (type_info), (t)); \
} \
} while (0)
Index: runtime/mercury_tabling_preds.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_tabling_preds.h,v
retrieving revision 1.12
diff -u -b -r1.12 mercury_tabling_preds.h
--- runtime/mercury_tabling_preds.h 6 Jul 2007 16:59:38 -0000 1.12
+++ runtime/mercury_tabling_preds.h 14 Aug 2007 07:16:03 -0000
@@ -1,5 +1,5 @@
/*
-** vim:ts=4 sw=4 expandtab
+** vim: ts=4 sw=4 et
*/
/*
** Copyright (C) 2004-2007 The University of Melbourne.
@@ -32,14 +32,14 @@
MR_tbl_lookup_insert_float(NULL, MR_FALSE, MR_FALSE, a, b, c)
#define MR_table_lookup_insert_enum(a, b, c, d) \
MR_tbl_lookup_insert_enum(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
-#define MR_table_lookup_insert_user(a, b, c, d) \
- MR_tbl_lookup_insert_user(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
-#define MR_table_lookup_insert_user_addr(a, b, c, d) \
- MR_tbl_lookup_insert_user_addr(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
-#define MR_table_lookup_insert_poly(a, b, c, d) \
- MR_tbl_lookup_insert_poly_addr(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
-#define MR_table_lookup_insert_poly_addr(a, b, c, d) \
- MR_tbl_lookup_insert_poly(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
+#define MR_table_lookup_insert_gen(a, b, c, d) \
+ MR_tbl_lookup_insert_gen(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
+#define MR_table_lookup_insert_gen_addr(a, b, c, d) \
+ MR_tbl_lookup_insert_gen_addr(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
+#define MR_table_lookup_insert_gen_poly(a, b, c, d) \
+ MR_tbl_lookup_insert_gen_poly(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
+#define MR_table_lookup_insert_gen_poly_addr(a, b, c, d) \
+ MR_tbl_lookup_insert_gen_poly_addr(NULL, MR_FALSE, MR_FALSE, a, b, c, d)
#define MR_table_lookup_insert_typeinfo(a, b, c) \
MR_tbl_lookup_insert_typeinfo(NULL, MR_FALSE, MR_FALSE, a, b, c)
#define MR_table_lookup_insert_typeclassinfo(a, b, c) \
@@ -176,24 +176,28 @@
MR_TABLE_ENUM(stats, debug, back, T, T0, R, V); \
} while(0)
-#define MR_tbl_lookup_insert_user(stats, debug, back, T0, TI, V, T) \
+#define MR_tbl_lookup_insert_gen(stats, debug, back, T0, TI, V, T) \
do { \
- MR_TABLE_ANY(stats, debug, back, T, T0, (MR_TypeInfo) TI, V); \
+ MR_TABLE_ANY(stats, debug, back, "gen", T, T0, \
+ (MR_TypeInfo) TI, (MR_Word) V); \
} while(0)
-#define MR_tbl_lookup_insert_user_addr(stats, debug, back, T0, TI, V, T) \
+#define MR_tbl_lookup_insert_gen_poly(stats, debug, back, T0, TI, V, T) \
do { \
- MR_TABLE_ANY_ADDR(stats, debug, back, T, T0, (MR_TypeInfo) TI, V); \
+ MR_TABLE_ANY(stats, debug, back, "gen poly", T, T0, \
+ (MR_TypeInfo) TI, (MR_Word) V); \
} while(0)
-#define MR_tbl_lookup_insert_poly(stats, debug, back, T0, TI, V, T) \
+#define MR_tbl_lookup_insert_gen_addr(stats, debug, back, T0, TI, V, T) \
do { \
- MR_TABLE_ANY(stats, debug, back, T, T0, (MR_TypeInfo) TI, V); \
+ MR_TABLE_ANY_ADDR(stats, debug, back, "gen addr", T, T0, \
+ (MR_TypeInfo) TI, (MR_Word) V); \
} while(0)
-#define MR_tbl_lookup_insert_poly_addr(stats, debug, back, T0, TI, V, T) \
+#define MR_tbl_lookup_insert_gen_poly_addr(stats, debug, back, T0, TI, V, T) \
do { \
- MR_TABLE_ANY_ADDR(stats, debug, back, T, T0, (MR_TypeInfo) TI, V); \
+ MR_TABLE_ANY_ADDR(stats, debug, back, "gen poly addr", T, T0, \
+ (MR_TypeInfo) TI, (MR_Word) V); \
} while(0)
#define MR_tbl_lookup_insert_typeinfo(stats, debug, back, T0, TI, T) \
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 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
Index: tests/tabling/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/tabling/Mmakefile,v
retrieving revision 1.45
diff -u -b -r1.45 Mmakefile
--- tests/tabling/Mmakefile 13 Aug 2007 03:01:59 -0000 1.45
+++ tests/tabling/Mmakefile 14 Aug 2007 05:52:05 -0000
@@ -11,6 +11,7 @@
expand_float \
expand_poly \
expand_tuple \
+ expand_tuple2 \
fast_loose \
fib \
fib_float \
Index: tests/tabling/expand_tuple2.exp
===================================================================
RCS file: tests/tabling/expand_tuple2.exp
diff -N tests/tabling/expand_tuple2.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/tabling/expand_tuple2.exp 14 Aug 2007 16:39:02 -0000
@@ -0,0 +1 @@
+Test successful.
Index: tests/tabling/expand_tuple2.m
===================================================================
RCS file: tests/tabling/expand_tuple2.m
diff -N tests/tabling/expand_tuple2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/tabling/expand_tuple2.m 14 Aug 2007 05:53:15 -0000
@@ -0,0 +1,89 @@
+% vim: ts=4 sw=4 et ft=mercury
+%
+% A test case to exercise the code for handling types that are statically known
+% to be tuples.
+%
+% The test is a modified version of expand_tuple.
+
+:- module expand_tuple2.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module bool.
+:- import_module int.
+:- import_module list.
+:- import_module random.
+:- import_module require.
+:- import_module std_util.
+:- import_module string.
+
+:- type record(T1, T2) ---> record(T1, T2, T1, T2).
+
+main(!IO) :-
+ random.init(0, RS0),
+ random.permutation(range(0, 1023), Perm, RS0, RS1),
+ choose_signs_and_enter(Perm, "0", Solns1, RS1, _RS2),
+ ( test_tables(Solns1, yes) ->
+ io.write_string("Test successful.\n", !IO)
+ ;
+ io.write_string("Test unsuccessful.\n", !IO)
+ ).
+ % io.report_tabling_stats(!IO).
+
+:- func range(int, int) = list(int).
+
+range(Min, Max) =
+ ( if Min > Max then
+ []
+ else
+ [Min | range(Min + 1, Max)]
+ ).
+
+:- pred choose_signs_and_enter(list(int)::in, string::in,
+ list(record(int, string))::out,
+ random.supply::mdi, random.supply::muo) is det.
+
+choose_signs_and_enter([], _, [], RS, RS).
+choose_signs_and_enter([N | Ns], A, [record(F, A, S, B) | ISs], RS0, RS) :-
+ random.random(Random, RS0, RS1),
+ ( Random mod 2 = 0 ->
+ F = N
+ ;
+ F = 0 - N
+ ),
+ sum({F, A}, {S, B}),
+ choose_signs_and_enter(Ns, A, ISs, RS1, RS).
+
+:- pred test_tables(list(record(int, string))::in, bool::out) is det.
+
+test_tables([], yes).
+test_tables([record(F, A, S0, B0) | Is], Correct) :-
+ sum({F, A}, {S1, B1}),
+ ( S0 = S1, B0 = B1 ->
+ test_tables(Is, Correct)
+ ;
+ Correct = no
+ ).
+
+:- pred sum({int, string}::in, {int, string}::out) is det.
+:- pragma memo(sum/2).
+
+sum({N, A}, {S, B}) :-
+ ( N < 0 ->
+ sum({0 - N, A}, {S0, B0}),
+ S = 0 - S0,
+ B = "-" ++ B0
+ ; N = 0 ->
+ S = 0,
+ B = A
+ ;
+ sum({N - 1, A}, {S0, B0}),
+ S = S0 + 1,
+ B = B0 ++ "+"
+ ).
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
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