Tabling final DIFF
Oliver Hutchison
ohutch at students.cs.mu.OZ.AU
Tue May 5 16:51:13 AEST 1998
Hi Fergus,
Here are to three files you wanted to have a look at. I hope you
better understand what is going on with table_suspend/resume given the new
comments. I am sorry about the delay with my response but I have been very
busy over the last month. I leave for Borneo on the 28th so I will need
some time before then to respond to any comments you have.
Thanks
Index: mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.94
diff -u -r1.94 mercury_builtin.m
--- mercury_builtin.m 1998/04/08 13:47:17 1.94
+++ mercury_builtin.m 1998/05/05 06:39:14
@@ -900,6 +900,933 @@
").
+
+:- interface.
+
+%
+% The following predicates are used in code transformed by the table_gen pass
+% of the compiler. The predicates fall into three categories :
+% 1) Predicates to do lookups or insertions into the tables. This group
+% also contains function to create and initialise tables. There are
+% currently two types of table used by the tabling system. 1) A subgoal
+% table, this is a table containing all of the subgoal calls that have
+% or are being processed for a given predicate. 2) An answer table,
+% this is a table of all the answers a subgoal has returned. It is used
+% for duplicate answer elimination in the minimal model tabling
+% scheme.
+%
+% 2) Predicates to test and set the status of the tables. These predicates
+% expect either a subgoal or answer table node depending on their
+% functionality.
+%
+% 3) Predicates to save answers into the tables. Answers are saved in
+% an answer block, which is a vector of n elements where n is the number
+% of output arguments of the predicate it belongs to. For det and
+% semidet tabling the answer block is connected directly to subgoal
+% table nodes. In the case of nondet tabling answer blocks are connected
+% to answered slots which are strung together to form a list.
+%
+% All of the predicates with the impure declaration modify the table
+% structures. Because the tables are persistent through backtracking, this
+% causes the predicates to become impure. The predicates with the semipure
+% directive only examine the trees but do not have any side effects.
+%
+
+ % This type is used as a generic table: it can in fact represent two
+ % types, either a subgoal_table or an answer_table. The subgoal_table
+ % and answer_table types are differentiated by what they have at the
+ % table nodes but not by the actual underling trie structure.
+:- type table.
+
+ % This type is used in contexts where a node of a subgoal table is
+ % expected.
+:- type subgoal_table_node.
+
+ % This type is used in contexts where a node of an answer table is
+ % expected.
+:- type answer_table_node.
+
+ % This type is used in contexts where an answer slot is expected.
+:- type answer_slot.
+
+ % This type is used in contexts where an answer block is expected.
+:- type answer_block.
+
+
+
+ % This is a dummy predicate: its pred_proc_id, but not its code,
+ % is used. See the comment in compiler/table_gen.m for more
+ % information.
+:- impure pred get_table(table).
+:- mode get_table(out) is det.
+
+ % Save important information in nondet table and initialise all of
+ % its fields. If called on an already initialised table do nothing.
+:- impure pred table_setup(subgoal_table_node, subgoal_table_node).
+:- mode table_setup(in, out) is det.
+
+
+
+ % Return all of the answer blocks stored in the given table.
+:- semipure pred table_return_all_ans(subgoal_table_node, answer_block).
+:- mode table_return_all_ans(in, out) is nondet.
+
+
+
+ % Returns true if the given nondet table has returned some of its
+ % answers.
+:- semipure pred table_have_some_ans(subgoal_table_node).
+:- mode table_have_some_ans(in) is semidet.
+
+ % Return true if the given nondet table has returned all of its
+ % answers.
+:- semipure pred table_have_all_ans(subgoal_table_node).
+:- mode table_have_all_ans(in) is semidet.
+
+
+ % Mark a table as having some answers.
+:- impure pred table_mark_have_some_ans(subgoal_table_node).
+:- mode table_mark_have_some_ans(in) is det.
+
+ % Make a table as having all of its answers.
+:- impure pred table_mark_have_all_ans(subgoal_table_node).
+:- mode table_mark_have_all_ans(in) is det.
+
+
+ % currently being evaluated (working on an answer).
+:- semipure pred table_working_on_ans(subgoal_table_node).
+:- mode table_working_on_ans(in) is semidet.
+
+ % Return false if the subgoal represented by the given table is
+ % currently being evaluated (working on an answer).
+:- semipure pred table_not_working_on_ans(subgoal_table_node).
+:- mode table_not_working_on_ans(in) is semidet.
+
+
+ % Mark the subgoal represented by the given table as currently
+ % being evaluated (working on an answer).
+:- impure pred table_mark_as_working(subgoal_table_node).
+:- mode table_mark_as_working(in) is det.
+
+ % Mark the subgoal represented by the given table as currently
+ % not being evaluated (working on an answer).
+:- impure pred table_mark_done_working(subgoal_table_node).
+:- mode table_mark_done_working(in) is det.
+
+
+
+ % Report an error message about the current subgoal looping.
+:- pred table_loopcheck_error(string).
+:- mode table_loopcheck_error(in) is erroneous.
+
+
+
+%
+% The following table_lookup_insert... predicates lookup or insert the second
+% argument into the trie pointed to by the first argument. The value returned
+% is a pointer to the leaf of the trie reached by the lookup. From the
+% returned leaf another trie may be connected.
+%
+ % Lookup or insert an integer in the given table.
+:- impure pred table_lookup_insert_int(table, int, table).
+:- mode table_lookup_insert_int(in, in, out) is det.
+
+ % Lookup or insert a character in the given trie.
+:- impure pred table_lookup_insert_char(table, character, table).
+:- mode table_lookup_insert_char(in, in, out) is det.
+
+ % Lookup or insert a string in the given trie.
+:- impure pred table_lookup_insert_string(table, string, table).
+:- mode table_lookup_insert_string(in, in, out) is det.
+
+ % Lookup or insert a float in the current trie.
+:- impure pred table_lookup_insert_float(table, float, table).
+:- mode table_lookup_insert_float(in, in, out) is det.
+
+ % Lookup or inert an enumeration type in the given trie.
+:- impure pred table_lookup_insert_enum(table, int, T, table).
+:- mode table_lookup_insert_enum(in, in, in, out) is det.
+
+ % Lookup or insert a monomorphic user defined type in the given trie.
+:- impure pred table_lookup_insert_user(table, T, table).
+:- mode table_lookup_insert_user(in, in, out) is det.
+
+ % Lookup or insert a polymorphic user defined type in the given trie.
+:- impure pred table_lookup_insert_poly(table, T, table).
+:- mode table_lookup_insert_poly(in, in, out) is det.
+
+
+ % Return true if the subgoal represented by the given table has an
+ % answer. NOTE : this is only used for det and semidet procedures.
+:- semipure pred table_have_ans(subgoal_table_node).
+:- mode table_have_ans(in) is semidet.
+
+
+ % Save the fact the the subgoal has succeeded in the given table.
+:- impure pred table_mark_as_succeeded(subgoal_table_node).
+:- mode table_mark_as_succeeded(in) is det.
+
+ % Save the fact the the subgoal has failed in the given table.
+:- impure pred table_mark_as_failed(subgoal_table_node).
+:- mode table_mark_as_failed(in) is det.
+
+
+ % Return true if the subgoal represented by the given table has a
+ % true answer. NOTE : this is only used for det and semidet
+ % procedures.
+:- semipure pred table_has_succeeded(subgoal_table_node).
+:- mode table_has_succeeded(in) is semidet.
+
+ % Return true if the subgoal represented by the given table has
+ % failed. NOTE : this is only used for semidet procedures.
+:- semipure pred table_has_failed(subgoal_table_node).
+:- mode table_has_failed(in) is semidet.
+
+
+ % Create an answer block with the given number of slots and add it
+ % to the given table.
+:- impure pred table_create_ans_block(subgoal_table_node, int, answer_block).
+:- mode table_create_ans_block(in, in, out) is det.
+
+ % Create a new slot in the answer list.
+:- impure pred table_new_ans_slot(subgoal_table_node, answer_slot).
+:- mode table_new_ans_slot(in, out) is det.
+
+ % Save an integer answer in the given answer block at the given
+ % offset.
+:- impure pred table_save_int_ans(answer_block, int, int).
+:- mode table_save_int_ans(in, in, in) is det.
+
+ % Save a character answer in the given answer block at the given
+ % offset.
+:- impure pred table_save_char_ans(answer_block, int, character).
+:- mode table_save_char_ans(in, in, in) is det.
+
+ % Save a string answer in the given answer block at the given
+ % offset.
+:- impure pred table_save_string_ans(answer_block, int, string).
+:- mode table_save_string_ans(in, in, in) is det.
+
+ % Save a float answer in the given answer block at the given
+ % offset.
+:- impure pred table_save_float_ans(answer_block, int, float).
+:- mode table_save_float_ans(in, in, in) is det.
+
+ % Save any type of answer in the given answer block at the given
+ % offset.
+:- impure pred table_save_any_ans(answer_block, int, T).
+:- mode table_save_any_ans(in, in, in) is det.
+
+
+ % Restore an integer answer from the given answer block at the
+ % given offset.
+:- semipure pred table_restore_int_ans(answer_block, int, int).
+:- mode table_restore_int_ans(in, in, out) is det.
+
+ % Restore a character answer from the given answer block at the
+ % given offset.
+:- semipure pred table_restore_char_ans(answer_block, int, character).
+:- mode table_restore_char_ans(in, in, out) is det.
+
+ % Restore a string answer from the given answer block at the
+ % given offset.
+:- semipure pred table_restore_string_ans(answer_block, int, string).
+:- mode table_restore_string_ans(in, in, out) is det.
+
+ % Restore a float answer from the given answer block at the
+ % given offset.
+:- semipure pred table_restore_float_ans(answer_block, int, float).
+:- mode table_restore_float_ans(in, in, out) is det.
+
+ % Restore any type of answer from the given answer block at the
+ % given offset.
+:- semipure pred table_restore_any_ans(answer_block, int, T).
+:- mode table_restore_any_ans(in, in, out) is det.
+
+
+ % Return the table of answers already return to the given nondet
+ % table.
+:- impure pred table_get_ans_table(subgoal_table_node, table).
+:- mode table_get_ans_table(in, out) is det.
+
+ % Return true if the answer represented by the given answer
+ % table has not been returned to its parent nondet table.
+:- semipure pred table_has_not_returned(answer_table_node).
+:- mode table_has_not_returned(in) is semidet.
+
+ % Make the answer represented by the given answer table as
+ % having been return to its parent nondet table.
+:- impure pred table_mark_as_returned(answer_table_node).
+:- mode table_mark_as_returned(in) is det.
+
+ % Save the state of the current subgoal and fail. When this subgoal
+ % is resumed answers are returned through the second argument.
+ % The saved state will be used by table_resume/1 to resume the
+ % subgoal.
+:- impure pred table_suspend(subgoal_table_node, answer_block).
+:- mode table_suspend(in, out) is nondet.
+
+ % Resume all suspended subgoal calls. This predicate will resume each
+ % of the suspended subgoals in turn until it reaches a fixed point at
+ % which all suspended subgoals have had all available answers returned
+ % to them.
+:- impure pred table_resume(subgoal_table_node).
+:- mode table_resume(in) is det.
+
+:- implementation.
+
+:- type table == c_pointer.
+:- type subgoal_table_node == c_pointer.
+:- type answer_table_node == c_pointer.
+:- type answer_slot == c_pointer.
+:- type answer_block == c_pointer.
+
+:- pragma c_header_code("
+
+ /* Used to mark the status of the table */
+#define ML_UNINITIALIZED 0
+#define ML_WORKING_ON_ANS 1
+#define ML_FAILED 2
+ /* The values 3..TYPELAYOUT_MAX_VARINT are reserved for future use */
+#define ML_SUCCEEDED TYPELAYOUT_MAX_VARINT
+ /* This or any greater value indicate that the subgoal has
+ ** succeeded. */
+
+").
+
+ % This is a dummy procedure that never actually gets called.
+ % See the comments in table_gen.m for its purpose.
+:- pragma c_code(get_table(_T::out), will_not_call_mercury, "").
+
+:- pragma c_code(table_working_on_ans(T::in), will_not_call_mercury, "
+ SUCCESS_INDICATOR = (*((Word*) T) == ML_WORKING_ON_ANS);
+").
+
+:- pragma c_code(table_not_working_on_ans(T::in), will_not_call_mercury, "
+ SUCCESS_INDICATOR = (*((Word*) T) != ML_WORKING_ON_ANS);
+").
+
+:- pragma c_code(table_mark_as_working(T::in), will_not_call_mercury, "
+ *((Word*) T) = ML_WORKING_ON_ANS;
+").
+
+:- pragma c_code(table_mark_done_working(T::in), will_not_call_mercury, "
+ *((Word*) T) = ML_UNINITIALIZED;
+").
+
+
+table_loopcheck_error(Message) :-
+ error(Message).
+
+
+:- pragma c_code(table_lookup_insert_int(T0::in, I::in, T::out),
+ will_not_call_mercury, "
+ T = (Word) MR_TABLE_INT((Word**)T0, I);
+").
+
+:- pragma c_code(table_lookup_insert_char(T0::in, C::in, T::out),
+ will_not_call_mercury, "
+ T = (Word) MR_TABLE_CHAR((Word **) T0, C);
+").
+
+:- pragma c_code(table_lookup_insert_string(T0::in, S::in, T::out),
+ will_not_call_mercury, "
+ T = (Word) MR_TABLE_STRING((Word **) T0, S);
+").
+
+:- pragma c_code(table_lookup_insert_float(T0::in, F::in, T::out),
+ will_not_call_mercury, "
+ T = (Word) MR_TABLE_FLOAT((Word **) T0, F);
+").
+
+:- pragma c_code(table_lookup_insert_enum(T0::in, R::in, V::in, T::out),
+ will_not_call_mercury, "
+ T = (Word) MR_TABLE_ENUM((Word **) T0, R, V);
+").
+
+:- pragma c_code(table_lookup_insert_user(T0::in, V::in, T::out),
+ will_not_call_mercury, "
+ T = (Word) MR_TABLE_ANY((Word **) T0, TypeInfo_for_T, V);
+").
+
+:- pragma c_code(table_lookup_insert_poly(T0::in, V::in, T::out),
+ will_not_call_mercury, "
+ Word T1 = (Word) MR_TABLE_TYPE_INFO((Word **) T0, TypeInfo_for_T);
+ T = (Word) MR_TABLE_ANY((Word **) T1, TypeInfo_for_T, V);
+").
+
+:- pragma c_code(table_have_ans(T::in), will_not_call_mercury, "
+ if (*((Word*) T) == ML_FAILED || *((Word*) T) >= ML_SUCCEEDED) {
+ SUCCESS_INDICATOR = TRUE;
+ } else {
+ SUCCESS_INDICATOR = FALSE;
+ }
+").
+
+:- pragma c_code(table_has_succeeded(T::in), will_not_call_mercury, "
+ SUCCESS_INDICATOR = (*((Word*) T) >= ML_SUCCEEDED)
+").
+
+:- pragma c_code(table_has_failed(T::in), will_not_call_mercury, "
+ SUCCESS_INDICATOR = (*((Word*) T) == ML_FAILED);
+").
+
+:- pragma c_code(table_create_ans_block(T0::in, Size::in, T::out) ,"
+ MR_TABLE_CREATE_ANSWER_BLOCK(T0, Size);
+ T = T0;
+").
+
+:- pragma c_code(table_save_int_ans(T::in, Offset::in, I::in),
+ will_not_call_mercury, "
+ MR_TABLE_SAVE_ANSWER(Offset, T, I,
+ mercury_data___base_type_info_int_0);
+").
+
+:- pragma c_code(table_save_char_ans(T::in, Offset::in, C::in),
+ will_not_call_mercury, "
+ MR_TABLE_SAVE_ANSWER(Offset, T, C,
+ mercury_data___base_type_info_char_0);
+").
+
+:- pragma c_code(table_save_string_ans(T::in, Offset::in, S::in),
+ will_not_call_mercury, "
+ MR_TABLE_SAVE_ANSWER(Offset, T, (Word) S,
+ mercury_data___base_type_info_string_0);
+").
+
+:- pragma c_code(table_save_float_ans(T::in, Offset::in, F::in),
+ will_not_call_mercury, "
+ MR_TABLE_SAVE_ANSWER(Offset, T, float_to_word(F),
+ mercury_data___base_type_info_float_0);
+").
+
+:- pragma c_code(table_save_any_ans(T::in, Offset::in, V::in),
+ will_not_call_mercury, "
+ MR_TABLE_SAVE_ANSWER(Offset, T, V, TypeInfo_for_T);
+").
+
+:- pragma c_code(table_mark_as_succeeded(T::in), will_not_call_mercury, "
+ *((Word*) T) = ML_SUCCEEDED;
+").
+
+:- pragma c_code(table_mark_as_failed(T::in), will_not_call_mercury, "
+ *((Word*) T) = ML_FAILED;
+").
+
+
+:- pragma c_code(table_restore_int_ans(T::in, Offset::in, I::out),
+ will_not_call_mercury, "
+ I = (Integer) MR_TABLE_GET_ANSWER(Offset, T);
+").
+
+:- pragma c_code(table_restore_char_ans(T::in, Offset::in, C::out),
+ will_not_call_mercury, "
+ C = (Char) MR_TABLE_GET_ANSWER(Offset, T);
+").
+
+:- pragma c_code(table_restore_string_ans(T::in, Offset::in, S::out),
+ will_not_call_mercury, "
+ S = (String) MR_TABLE_GET_ANSWER(Offset, T);
+").
+
+:- pragma c_code(table_restore_float_ans(T::in, Offset::in, F::out),
+ will_not_call_mercury, "
+ F = word_to_float(MR_TABLE_GET_ANSWER(Offset, T));
+").
+
+:- pragma c_code(table_restore_any_ans(T::in, Offset::in, V::out),
+ will_not_call_mercury, "
+ V = (Word) MR_TABLE_GET_ANSWER(Offset, T);
+").
+
+
+:- pragma c_header_code("
+
+/*
+** The following structures are used by the code for non deterministic tabling.
+*/
+
+/* Used to hold a single answer. */
+typedef struct {
+ Word ans_num;
+ Word ans;
+} AnswerListNode;
+
+/* Used to save the state of a subgoal */
+typedef struct {
+ Word *last_ret_ans; /* Pointer to the last answer returned
+ to the node */
+ Code *succ_ip; /* Saved succip */
+ Word *s_p; /* Saved SP */
+ Word *cur_fr; /* Saved curfr */
+ Word *max_fr; /* Saved maxfr */
+ Word non_stack_block_size; /* Size of saved non stack block */
+ Word *non_stack_block; /* Saved non stack */
+ Word det_stack_block_size; /* Size of saved det stack block */
+ Word *det_stack_block; /* Saved det stack */
+} SuspendListNode;
+
+typedef enum {
+ have_no_ans,
+ have_some_ans,
+ have_all_ans
+} TableStatus;
+
+/* Used to save info about a single subgoal in the table */
+typedef struct {
+ TableStatus status; /* Status of subgoal */
+ Word answer_table; /* Table of answers returned by the
+ subgoal */
+ Word num_ans; /* Number of answers returned by the
+ subgoal */
+ Word answer_list; /* List of answers returned by the
+ subgoal */
+ Word *answer_list_tail; /* Pointer to the tail of the answer
+ list. This is used to update the
+ tail rather than the head of the
+ ans list. */
+ Word suspend_list; /* List of suspended calls to the
+ subgoal */
+ Word *suspend_list_tail; /* Ditto for answer_list_tail */
+ Word *non_stack_bottom; /* Pointer to the bottom point of
+ the nondet stack from which to
+ copy */
+ Word *det_stack_bottom; /* Pointer to the bottom point of
+ the det stack from which to copy */
+
+} NondetTable;
+
+ /* Flag used to indicate the answer has been returned */
+#define ML_ANS_NOT_RET 0
+#define ML_ANS_RET 1
+
+ /*
+ ** Cast a Word to a NondetTable*: saves on typing and improves
+ ** readability.
+ */
+#define NON_TABLE(T) (*(NondetTable **)T)
+").
+
+
+:- pragma c_code(table_setup(T0::in, T::out), will_not_call_mercury, "
+ /* Init the table if this is the first time me see it */
+ if (NON_TABLE(T0) == NULL) {
+ NON_TABLE(T0) = (NondetTable *) table_allocate(
+ sizeof(NondetTable));
+ NON_TABLE(T0)->status = have_no_ans;
+ NON_TABLE(T0)->answer_table = (Word) NULL;
+ NON_TABLE(T0)->num_ans = 0;
+ NON_TABLE(T0)->answer_list = list_empty();
+ NON_TABLE(T0)->answer_list_tail =
+ &NON_TABLE(T0)->answer_list;
+ NON_TABLE(T0)->suspend_list = list_empty();
+ NON_TABLE(T0)->suspend_list_tail =
+ &NON_TABLE(T0)->suspend_list;
+ NON_TABLE(T0)->non_stack_bottom = curprevfr;
+ NON_TABLE(T0)->det_stack_bottom = MR_sp;
+ }
+ T = T0;
+").
+
+
+table_return_all_ans(T, A) :-
+ semipure table_return_all_ans_list(T, AnsList),
+ list__member(Node, AnsList),
+ semipure table_return_all_ans_2(Node, A).
+
+:- semipure pred table_return_all_ans_list(table, list(table)).
+:- mode table_return_all_ans_list(in, out) is det.
+
+:- pragma c_code(table_return_all_ans_list(T::in, A::out),
+ will_not_call_mercury, "
+ A = NON_TABLE(T)->answer_list;
+").
+
+:- semipure pred table_return_all_ans_2(table, table).
+:- mode table_return_all_ans_2(in, out) is det.
+
+:- pragma c_code(table_return_all_ans_2(P::in, A::out),
+ will_not_call_mercury, "
+ A = (Word) &((AnswerListNode*) P)->ans;
+").
+
+:- pragma c_code(table_get_ans_table(T::in, AT::out),
+ will_not_call_mercury, "
+ AT = (Word) &(NON_TABLE(T)->answer_table);
+").
+
+:- pragma c_code(table_have_all_ans(T::in),"
+ SUCCESS_INDICATOR = (NON_TABLE(T)->status == have_all_ans);
+").
+
+:- pragma c_code(table_have_some_ans(T::in), will_not_call_mercury, "
+ SUCCESS_INDICATOR = (NON_TABLE(T)->status == have_some_ans);
+").
+
+:- pragma c_code(table_has_not_returned(T::in), will_not_call_mercury, "
+ SUCCESS_INDICATOR = (*((Word*) T) == ML_ANS_NOT_RET);
+").
+
+
+
+:- pragma c_code(table_mark_have_all_ans(T::in), will_not_call_mercury, "
+ NON_TABLE(T)->status = have_all_ans;
+").
+
+:- pragma c_code(table_mark_have_some_ans(T::in), will_not_call_mercury, "
+ NON_TABLE(T)->status = have_some_ans;
+").
+
+:- pragma c_code(table_mark_as_returned(T::in), will_not_call_mercury, "
+ *((Word *) T) = ML_ANS_RET;
+").
+
+
+:- external(table_suspend/2).
+:- external(table_resume/1).
+
+:- pragma c_code("
+
+/*
+** The following procedure saves the state of the mercury runtime
+** so that it may be used in the table_resume procedure bellow to return
+** answers through this saved state. The procedure table_suspend is
+** declared as nondet but the code bellow is obviously of detism failure,
+** the reason for this is quite simple. Normally when a nondet proc
+** is called it will first return all of its answers and then fail. In the
+** case of calls to this procedure this is reversed first the call will fail
+** then later on, when the answers are found, answers will be returned.
+** It is also important to note that the answers are returned not from the
+** procedure that was originally called (table_suspend) but from the procedure
+** table_resume. So essentially what is bellow is the code to do the initial
+** fail the code to return the answers is in table_resume.
+*/
+Define_extern_entry(mercury__table_suspend_2_0);
+MR_MAKE_STACK_LAYOUT_ENTRY(mercury__table_suspend_2_0);
+BEGIN_MODULE(table_suspend_module)
+ init_entry_sl(mercury__table_suspend_2_0);
+BEGIN_CODE
+
+Define_entry(mercury__table_suspend_2_0);
+{
+ Word *non_stack_top = MR_maxfr;
+ Word *det_stack_top = MR_sp;
+ Word *non_stack_bottom = NON_TABLE(r1)->non_stack_bottom;
+ Word *det_stack_bottom = NON_TABLE(r1)->det_stack_bottom;
+ Word non_stack_delta = non_stack_top - non_stack_bottom;
+ Word det_stack_delta = det_stack_top - det_stack_bottom;
+ Word ListNode;
+ SuspendListNode *Node = table_allocate(sizeof(SuspendListNode));
+
+ Node->last_ret_ans = &(NON_TABLE(r1)->answer_list);
+
+ Node->non_stack_block_size = non_stack_delta;
+ Node->non_stack_block = table_allocate(non_stack_delta);
+ table_copy_mem((void *)Node->non_stack_block, (void *)non_stack_bottom,
+ non_stack_delta);
+
+ Node->det_stack_block_size = det_stack_delta;
+ Node->det_stack_block = table_allocate(det_stack_delta);
+ table_copy_mem((void *)Node->det_stack_block, (void *)det_stack_bottom,
+ det_stack_delta);
+
+ Node->succ_ip = MR_succip;
+ Node->s_p = MR_sp;
+ Node->cur_fr = MR_curfr;
+ Node->max_fr = MR_maxfr;
+
+ ListNode = list_cons(Node, *NON_TABLE(r1)->suspend_list_tail);
+ *NON_TABLE(r1)->suspend_list_tail = ListNode;
+ NON_TABLE(r1)->suspend_list_tail = &list_tail(ListNode);
+}
+ fail();
+END_MODULE
+
+/*
+** The following structure is used to hold the state and variables used in
+** the table_resume procedure. The state and variables must be held in a
+** globally rooted structure as the process of resuming overwrites the mercury
+** and C stacks. A new stack is used to avoid this overwriting. This stack is
+** defined and accessed by the following macros and global variables.
+*/
+typedef struct {
+ NondetTable *table;
+ Word non_stack_block_size;
+ Word *non_stack_block;
+ Word det_stack_block_size;
+ Word *det_stack_block;
+
+ Code *succ_ip;
+ Word *s_p;
+ Word *cur_fr;
+ Word *max_fr;
+
+ Word changed;
+ Word num_ans, new_num_ans;
+ Word suspend_list;
+ SuspendListNode *suspend_node;
+ Word ans_list;
+ AnswerListNode *ansNode;
+} ResumeStackNode;
+
+
+Integer ML_resumption_sp = -1;
+Word ML_resumption_stack_size = 4; /* Half the initial size of
+ the stack in ResumeStackNode's */
+
+ResumeStackNode** ML_resumption_stack = NULL;
+
+#define ML_RESUME_PUSH() \
+ do { \
+ ++ML_resumption_sp; \
+ if (ML_resumption_sp >= ML_resumption_stack_size || \
+ ML_resumption_stack == NULL) \
+ { \
+ ML_resumption_stack_size = \
+ ML_resumption_stack_size*2; \
+ ML_resumption_stack = table_reallocate( \
+ ML_resumption_stack, \
+ ML_resumption_stack_size*sizeof( \
+ ResumeStackNode*)); \
+ } \
+ ML_resumption_stack[ML_resumption_sp] = table_allocate( \
+ sizeof(ResumeStackNode)); \
+ } while (0)
+
+#define ML_RESUME_POP() \
+ do { \
+ if (ML_resumption_sp < 0) { \
+ fatal_error(""resumption stack underflow""); \
+ } \
+ table_free(ML_resumption_stack[ML_resumption_sp]); \
+ --ML_resumption_sp; \
+ } while (0)
+
+#define ML_RESUME_VAR \
+ ML_resumption_stack[ML_resumption_sp]
+
+/*
+** The procedure defined below restores answers to suspended nodes. It
+** works by restoring the states saved when calls to table_suspend were
+** made. By restoring the states saved in table_suspend and then returning
+** answers it is essentially returning answers out of the call to table_suspend
+** not out of the call to table_resume.
+** This procedure iterates until it has returned all answers to all
+** suspend nodes. The iteration is a fixpoint type as each time an answer
+** is returned to a suspended node it has the chance of introducing more
+** answers and/or suspended nodes.
+*/
+Define_extern_entry(mercury__table_resume_1_0);
+Declare_label(mercury__table_resume_1_0_ChangeLoop);
+Declare_label(mercury__table_resume_1_0_ChangeLoopDone);
+Declare_label(mercury__table_resume_1_0_SolutionsListLoop);
+Declare_label(mercury__table_resume_1_0_AnsListLoop);
+Declare_label(mercury__table_resume_1_0_AnsListLoopDone);
+Declare_label(mercury__table_resume_1_0_SkipAns);
+Declare_label(mercury__table_resume_1_0_RedoPoint);
+
+MR_MAKE_STACK_LAYOUT_ENTRY(mercury__table_resume_1_0);
+
+BEGIN_MODULE(table_resume_module)
+ init_entry_sl(mercury__table_resume_1_0);
+ init_label_sl(mercury__table_resume_1_0_ChangeLoop);
+ init_label_sl(mercury__table_resume_1_0_ChangeLoopDone);
+ init_label_sl(mercury__table_resume_1_0_SolutionsListLoop);
+ init_label_sl(mercury__table_resume_1_0_AnsListLoop);
+ init_label_sl(mercury__table_resume_1_0_AnsListLoopDone);
+ init_label_sl(mercury__table_resume_1_0_SkipAns);
+ init_label_sl(mercury__table_resume_1_0_RedoPoint);
+BEGIN_CODE
+
+Define_entry(mercury__table_resume_1_0);
+ /* Check that we have answers to return and nodes to return
+ them to. */
+ if (list_is_empty(NON_TABLE(r1)->answer_list) ||
+ list_is_empty(NON_TABLE(r1)->suspend_list))
+ proceed();
+
+ /* Save the current state. */
+ ML_RESUME_PUSH();
+ ML_RESUME_VAR->table = NON_TABLE(r1);
+ ML_RESUME_VAR->non_stack_block_size = (char *) MR_maxfr -
+ (char *) ML_RESUME_VAR->table->non_stack_bottom;
+ ML_RESUME_VAR->det_stack_block_size = (char *) MR_sp -
+ (char *) ML_RESUME_VAR->table->det_stack_bottom;
+ ML_RESUME_VAR->succ_ip = MR_succip;
+ ML_RESUME_VAR->s_p = MR_sp;
+ ML_RESUME_VAR->cur_fr = MR_curfr;
+ ML_RESUME_VAR->max_fr = MR_maxfr;
+
+ ML_RESUME_VAR->changed = 1;
+
+ ML_RESUME_VAR->non_stack_block = (Word *) table_allocate(
+ ML_RESUME_VAR->non_stack_block_size);
+ table_copy_mem(ML_RESUME_VAR->non_stack_block,
+ ML_RESUME_VAR->table->non_stack_bottom,
+ ML_RESUME_VAR->non_stack_block_size);
+
+ ML_RESUME_VAR->det_stack_block = (Word *) table_allocate(
+ ML_RESUME_VAR->det_stack_block_size);
+ table_copy_mem(ML_RESUME_VAR->det_stack_block,
+ ML_RESUME_VAR->table->det_stack_bottom,
+ ML_RESUME_VAR->det_stack_block_size);
+
+ /* If the number of ans or suspended nodes has changed. */
+Define_label(mercury__table_resume_1_0_ChangeLoop);
+ if (! ML_RESUME_VAR->changed)
+ GOTO_LABEL(mercury__table_resume_1_0_ChangeLoopDone);
+
+ ML_RESUME_VAR->suspend_list = ML_RESUME_VAR->table->suspend_list;
+
+ ML_RESUME_VAR->changed = 0;
+ ML_RESUME_VAR->num_ans = ML_RESUME_VAR->table->num_ans;
+
+ /* For each of the suspended nodes */
+Define_label(mercury__table_resume_1_0_SolutionsListLoop);
+ if (list_is_empty(ML_RESUME_VAR->suspend_list))
+ GOTO_LABEL(mercury__table_resume_1_0_ChangeLoop);
+
+ ML_RESUME_VAR->suspend_node = (SuspendListNode *)list_head(
+ ML_RESUME_VAR->suspend_list);
+
+ ML_RESUME_VAR->ans_list = *ML_RESUME_VAR->suspend_node->
+ last_ret_ans;
+
+ if (list_is_empty(ML_RESUME_VAR->ans_list))
+ GOTO_LABEL(mercury__table_resume_1_0_AnsListLoopDone2);
+
+ ML_RESUME_VAR->ansNode = (AnswerListNode *)list_head(
+ ML_RESUME_VAR->ans_list);
+
+
+ /*
+ ** Restore the state of the suspended node and return the answer
+ ** through the redoip we saved when the node was originally
+ ** suspended
+ */
+
+ table_copy_mem(ML_RESUME_VAR->table->non_stack_bottom,
+ ML_RESUME_VAR->suspend_node->non_stack_block,
+ ML_RESUME_VAR->suspend_node->non_stack_block_size);
+
+ table_copy_mem(ML_RESUME_VAR->table->det_stack_bottom,
+ ML_RESUME_VAR->suspend_node->det_stack_block,
+ ML_RESUME_VAR->suspend_node->det_stack_block_size);
+
+ MR_succip = ML_RESUME_VAR->suspend_node->succ_ip;
+ MR_sp = ML_RESUME_VAR->suspend_node->s_p;
+ MR_curfr = ML_RESUME_VAR->suspend_node->cur_fr;
+ MR_maxfr = ML_RESUME_VAR->suspend_node->max_fr;
+
+ bt_redoip(maxfr) = LABEL(mercury__table_resume_1_0_RedoPoint);
+
+ /*
+ ** For each answer not returned to the node whose state we are
+ ** currently in.
+ */
+Define_label(mercury__table_resume_1_0_AnsListLoop);
+#ifdef COMPACT_ARGS
+ r1 = (Word) &ML_RESUME_VAR->ansNode->ans;
+#else
+ r2 = (word) &ML_RESUME_VAR->ansNode->ans;
+#endif
+
+ /*
+ ** Return the answer though the point where suspend should have
+ ** returned.
+ */
+ succeed();
+
+Define_label(mercury__table_resume_1_0_RedoPoint);
+ update_prof_current_proc(LABEL(mercury__table_resume_1_0));
+
+ ML_RESUME_VAR->ans_list = list_tail(ML_RESUME_VAR->ans_list);
+
+ if (list_is_empty(ML_RESUME_VAR->ans_list))
+ GOTO_LABEL(mercury__table_resume_1_0_AnsListLoopDone1);
+
+ ML_RESUME_VAR->ansNode = (AnswerListNode *)list_head(
+ ML_RESUME_VAR->ans_list);
+
+ GOTO_LABEL(mercury__table_resume_1_0_AnsListLoop);
+
+Define_label(mercury__table_resume_1_0_AnsListLoopDone1);
+ if (ML_RESUME_VAR->num_ans == ML_RESUME_VAR->table->num_ans)
+ ML_RESUME_VAR->changed = 0;
+ else
+ ML_RESUME_VAR->changed = 1;
+
+
+ ML_RESUME_VAR->suspend_node->last_ret_ans =
+ &ML_RESUME_VAR->ans_list;
+
+Define_label(mercury__table_resume_1_0_AnsListLoopDone2);
+ ML_RESUME_VAR->suspend_list = list_tail(ML_RESUME_VAR->suspend_list);
+ GOTO_LABEL(mercury__table_resume_1_0_SolutionsListLoop);
+
+Define_label(mercury__table_resume_1_0_SkipAns);
+ ML_RESUME_VAR->ans_list = list_tail(ML_RESUME_VAR->ans_list);
+ GOTO_LABEL(mercury__table_resume_1_0_AnsListLoop);
+
+Define_label(mercury__table_resume_1_0_ChangeLoopDone);
+ /* Restore the original state we had when this proc was called */
+
+ table_copy_mem(ML_RESUME_VAR->table->non_stack_bottom,
+ ML_RESUME_VAR->non_stack_block,
+ ML_RESUME_VAR->non_stack_block_size);
+ table_free(ML_RESUME_VAR->non_stack_block);
+
+ table_copy_mem(ML_RESUME_VAR->table->det_stack_bottom,
+ ML_RESUME_VAR->det_stack_block,
+ ML_RESUME_VAR->det_stack_block_size);
+ table_free(ML_RESUME_VAR->det_stack_block);
+
+ MR_succip = ML_RESUME_VAR->succ_ip;
+ MR_sp = ML_RESUME_VAR->s_p;
+ MR_curfr = ML_RESUME_VAR->cur_fr;
+ MR_maxfr = ML_RESUME_VAR->max_fr;
+
+ ML_RESUME_POP();
+
+ proceed();
+END_MODULE
+
+/* Ensure that the initialization code for the above module gets run. */
+/*
+INIT sys_init_table_suspend_module
+INIT sys_init_table_resume_module
+*/
+void sys_init_table_suspend_module(void);
+ /* extra declaration to suppress gcc -Wmissing-decl warning */
+void sys_init_table_suspend_module(void) {
+ extern ModuleFunc table_suspend_module;
+ table_suspend_module();
+}
+void sys_init_table_resume_module(void);
+ /* extra declaration to suppress gcc -Wmissing-decl warning */
+void sys_init_table_resume_module(void) {
+ extern ModuleFunc table_resume_module;
+ table_resume_module();
+}
+
+").
+
+:- pragma c_code(table_new_ans_slot(T::in, Slot::out),
+ will_not_call_mercury, "
+ Word ListNode;
+ Word ans_num;
+ AnswerListNode *n = table_allocate(sizeof(AnswerListNode));
+
+ ++(NON_TABLE(T)->num_ans);
+ ans_num = NON_TABLE(T)->num_ans;
+ n->ans_num = ans_num;
+ n->ans = 0;
+ ListNode = list_cons(n, *NON_TABLE(T)->answer_list_tail);
+ *NON_TABLE(T)->answer_list_tail = ListNode;
+ NON_TABLE(T)->answer_list_tail = &list_tail(ListNode);
+
+ Slot = (Word) &n->ans;
+").
:- end_module mercury_builtin.
Index: ../runtime/mercury_type_info.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.4
diff -u -r1.4 mercury_type_info.c
--- mercury_type_info.c 1998/01/06 07:06:04 1.4
+++ mercury_type_info.c 1998/05/01 05:47:39
@@ -151,7 +151,397 @@
fatal_error("attempted comparison of higher-order terms");
END_MODULE
+ /*
+ ** Given a type_info (term_type_info) which contains a
+ ** base_type_info pointer and possibly other type_infos
+ ** giving the values of the type parameters of this type,
+ ** and a pseudo-type_info (arg_pseudo_type_info), which contains a
+ ** base_type_info pointer and possibly other type_infos
+ ** giving EITHER
+ ** - the values of the type parameters of this type,
+ ** or - an indication of the type parameter of the
+ ** term_type_info that should be substituted here
+ **
+ ** This returns a fully instantiated type_info, a version of the
+ ** arg_pseudo_type_info with all the type variables filled in.
+ **
+ ** We allocate memory for a new type_info on the Mercury heap,
+ ** copy the necessary information, and return a pointer to the
+ ** new type_info.
+ **
+ ** In the case where the argument's pseudo_type_info is a
+ ** base_type_info with no arguments, we don't copy the
+ ** base_type_info - we just return a pointer to it - no memory
+ ** is allocated. The caller can check this by looking at the
+ ** first cell of the returned pointer - if it is zero, this is a
+ ** base_type_info. Otherwise, it is an allocated copy of a
+ ** type_info.
+ **
+ ** NOTE: If you are changing this code, you might also need
+ ** to change the code in MR_make_type_info in this module
+ ** which does much the same thing, only allocating using malloc
+ ** instead of on the heap.
+ */
+
+Word *
+MR_create_type_info(Word *term_type_info, Word *arg_pseudo_type_info)
+{
+ int i, arity, extra_args;
+ Word *base_type_info;
+ Word *arg_type_info;
+ Word *type_info;
+
+ /*
+ ** The arg_pseudo_type_info might be a polymorphic variable.
+ ** If so, then substitute it's value, and then we're done.
+ */
+ if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
+ arg_type_info = (Word *)
+ term_type_info[(Word) arg_pseudo_type_info];
+
+ if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
+ fatal_error("MR_create_type_info: "
+ "unbound type variable");
+ }
+
+ return arg_type_info;
+ }
+
+ base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(arg_pseudo_type_info);
+
+ /* no arguments - optimise common case */
+ if (base_type_info == arg_pseudo_type_info) {
+ return arg_pseudo_type_info;
+ }
+
+ if (MR_BASE_TYPEINFO_IS_HO(base_type_info)) {
+ arity = MR_TYPEINFO_GET_HIGHER_ARITY(arg_pseudo_type_info);
+ extra_args = 2;
+ } else {
+ arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ extra_args = 1;
+ }
+
+ /*
+ ** Iterate over the arguments, figuring out whether we
+ ** need to make any substitutions.
+ ** If so, copy the resulting argument type-infos into
+ ** a new type_info.
+ */
+ type_info = NULL;
+ for (i = extra_args; i < arity + extra_args; i++) {
+ arg_type_info = MR_create_type_info(term_type_info,
+ (Word *) arg_pseudo_type_info[i]);
+ if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
+ fatal_error("MR_create_type_info: "
+ "unbound type variable");
+ }
+ if (arg_type_info != (Word *) arg_pseudo_type_info[i]) {
+ /*
+ ** We made a substitution.
+ ** We need to allocate a new type_info,
+ ** if we haven't done so already.
+ */
+ if (type_info == NULL) {
+ incr_saved_hp(LVALUE_CAST(Word, type_info),
+ arity + extra_args);
+ memcpy(type_info, arg_pseudo_type_info,
+ (arity + extra_args) * sizeof(Word));
+ }
+ type_info[i] = (Word) arg_type_info;
+ }
+ }
+ if (type_info == NULL) {
+ return arg_pseudo_type_info;
+ } else {
+ return type_info;
+ }
+}
+
+/*
+** MR_compare_type_info(type_info_1, type_info_2):
+**
+** Compare two type_info structures, using an arbitrary ordering
+** (based on the addresses of the base_type_infos, or in
+** the case of higher order types, the arity).
+**
+** You need to save and restore transient registers around
+** calls to this function.
+*/
+
+int
+MR_compare_type_info(Word t1, Word t2)
+{
+ Word *type_info_1, *type_info_2;
+ Word *base_type_info_1, *base_type_info_2;
+ int num_arg_types;
+ int i;
+
+ /*
+ ** Try to optimize a common case:
+ ** If type_info addresses are equal, they must represent the
+ ** same type.
+ */
+ if (t1 == t2) {
+ return COMPARE_EQUAL;
+ }
+
+ /*
+ ** Otherwise, we need to expand equivalence types, if any.
+ */
+ type_info_1 = (Word *) MR_collapse_equivalences(t1);
+ type_info_2 = (Word *) MR_collapse_equivalences(t2);
+
+ /*
+ ** Perhaps they are equal now...
+ */
+ if (type_info_1 == type_info_2) {
+ return COMPARE_EQUAL;
+ }
+
+ /*
+ ** Otherwise find the addresses of the base_type_infos,
+ ** and compare those.
+ **
+ ** Note: this is an arbitrary ordering. It doesn't matter
+ ** what the ordering is, just so long as it is consistent.
+ ** ANSI C doesn't guarantee much about pointer comparisons,
+ ** so it is possible that this might not do the right thing
+ ** on some obscure systems.
+ ** The casts to (Word) here are in the hope of increasing
+ ** the chance that this will work on a segmented architecture.
+ */
+ base_type_info_1 = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info_1);
+ base_type_info_2 = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info_2);
+ if ((Word) base_type_info_1 < (Word) base_type_info_2) {
+ return COMPARE_LESS;
+ }
+ if ((Word) base_type_info_1 > (Word) base_type_info_2) {
+ return COMPARE_GREATER;
+ }
+
+ /*
+ ** If the base_type_info addresses are equal, we don't need to
+ ** compare the arity of the types - they must be the same -
+ ** unless they are higher-order (which are all mapped to
+ ** pred/0).
+ ** But we need to recursively compare the argument types, if any.
+ */
+ /* Check for higher order */
+ if (MR_BASE_TYPEINFO_IS_HO(base_type_info_1))
+ {
+ int num_arg_types_2;
+
+ /* Get number of arguments from type_info */
+ num_arg_types = field(mktag(0), type_info_1,
+ TYPEINFO_OFFSET_FOR_PRED_ARITY);
+
+ num_arg_types_2 = field(mktag(0), type_info_2,
+ TYPEINFO_OFFSET_FOR_PRED_ARITY);
+
+ /* Check arity */
+ if (num_arg_types < num_arg_types_2) {
+ return COMPARE_LESS;
+ }
+ if (num_arg_types > num_arg_types_2) {
+ return COMPARE_GREATER;
+ }
+
+ /*
+ ** Increment, so arguments are at the
+ ** expected offset.
+ */
+ type_info_1++;
+ type_info_2++;
+ } else {
+ num_arg_types = field(mktag(0), base_type_info_1,
+ OFFSET_FOR_COUNT);
+ }
+ /* compare the argument types */
+ for (i = 0; i < num_arg_types; i++) {
+ Word arg_type_info_1 = field(mktag(0), type_info_1,
+ OFFSET_FOR_ARG_TYPE_INFOS + i);
+ Word arg_type_info_2 = field(mktag(0), type_info_2,
+ OFFSET_FOR_ARG_TYPE_INFOS + i);
+ int comp = MR_compare_type_info(
+ arg_type_info_1, arg_type_info_2);
+ if (comp != COMPARE_EQUAL)
+ return comp;
+ }
+ return COMPARE_EQUAL;
+}
+
+ /*
+ ** MR_collapse_equivalences:
+ **
+ ** Keep looking past equivalences until the there are no more.
+ ** This only looks past equivalences of the top level type, not
+ ** the argument typeinfos.
+ **
+ ** You need to save and restore transient registers around
+ ** calls to this function.
+ */
+
+Word
+MR_collapse_equivalences(Word maybe_equiv_type_info)
+{
+ Word *functors, equiv_type_info;
+
+ functors = MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(
+ MR_TYPEINFO_GET_BASE_TYPEINFO((Word *)
+ maybe_equiv_type_info));
+
+ /* Look past equivalences */
+ while (MR_TYPEFUNCTORS_INDICATOR(functors) == MR_TYPEFUNCTORS_EQUIV) {
+ equiv_type_info = (Word) MR_TYPEFUNCTORS_EQUIV_TYPE(functors);
+ equiv_type_info = (Word) MR_create_type_info(
+ (Word *) maybe_equiv_type_info,
+ (Word *) equiv_type_info);
+ functors = MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(
+ MR_TYPEINFO_GET_BASE_TYPEINFO((Word *)
+ equiv_type_info));
+ maybe_equiv_type_info = equiv_type_info;
+ }
+
+ return maybe_equiv_type_info;
+}
+
+
+/*
+** MR_deallocate() frees up a list of memory cells
+*/
+void
+MR_deallocate(MR_MemoryList allocated)
+{
+ while (allocated != NULL) {
+ MR_MemoryList next = allocated->next;
+ free(allocated->data);
+ free(allocated);
+ allocated = next;
+ }
+}
+
+ /*
+ ** Given a type_info (term_type_info) which contains a
+ ** base_type_info pointer and possibly other type_infos
+ ** giving the values of the type parameters of this type,
+ ** and a pseudo-type_info (arg_pseudo_type_info), which contains a
+ ** base_type_info pointer and possibly other type_infos
+ ** giving EITHER
+ ** - the values of the type parameters of this type,
+ ** or - an indication of the type parameter of the
+ ** term_type_info that should be substituted here
+ **
+ ** This returns a fully instantiated type_info, a version of the
+ ** arg_pseudo_type_info with all the type variables filled in.
+ ** If there are no type variables to fill in, we return the
+ ** arg_pseudo_type_info, unchanged. Otherwise, we allocate
+ ** memory using malloc(). Any such memory allocated will be
+ ** inserted into the list of allocated memory cells.
+ ** It is the caller's responsibility to free these cells
+ ** by calling MR_deallocate() on the list when they are no longer
+ ** needed.
+ **
+ ** This code could be tighter. In general, we want to
+ ** handle our own allocations rather than using malloc().
+ **
+ ** NOTE: If you are changing this code, you might also need
+ ** to change the code in create_type_info in library/std_util.m,
+ ** which does much the same thing, only allocating on the
+ ** heap instead of using malloc.
+ */
+
+Word *
+MR_make_type_info(Word *term_type_info, Word *arg_pseudo_type_info,
+ MR_MemoryList *allocated)
+{
+ int i, arity, extra_args;
+ Word *base_type_info;
+ Word *arg_type_info;
+ Word *type_info;
+
+ /*
+ ** The arg_pseudo_type_info might be a polymorphic variable.
+ ** If so, then substitute its value, and then we're done.
+ */
+ if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
+ arg_type_info = (Word *)
+ term_type_info[(Word) arg_pseudo_type_info];
+ if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
+ fatal_error("make_type_info: "
+ "unbound type variable");
+ }
+ return arg_type_info;
+ }
+
+ base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(arg_pseudo_type_info);
+
+ /* no arguments - optimise common case */
+ if (base_type_info == arg_pseudo_type_info) {
+ return arg_pseudo_type_info;
+ }
+
+ if (MR_BASE_TYPEINFO_IS_HO(base_type_info)) {
+ arity = MR_TYPEINFO_GET_HIGHER_ARITY(arg_pseudo_type_info);
+ extra_args = 2;
+ } else {
+ arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ extra_args = 1;
+ }
+
+ /*
+ ** Iterate over the arguments, figuring out whether we
+ ** need to make any substitutions.
+ ** If so, copy the resulting argument type-infos into
+ ** a new type_info.
+ */
+ type_info = NULL;
+ for (i = extra_args; i < arity + extra_args; i++) {
+ arg_type_info = MR_make_type_info(term_type_info,
+ (Word *) arg_pseudo_type_info[i], allocated);
+ if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
+ fatal_error("MR_make_type_info: "
+ "unbound type variable");
+ }
+ if (arg_type_info != (Word *) arg_pseudo_type_info[i]) {
+ /*
+ ** We made a substitution.
+ ** We need to allocate a new type_info,
+ ** if we haven't done so already.
+ */
+ if (type_info == NULL) {
+ MR_MemoryList node;
+ /*
+ ** allocate a new type_info and copy the
+ ** data across from arg_pseduo_type_info
+ */
+ type_info = checked_malloc(
+ (arity + extra_args) * sizeof(Word));
+ memcpy(type_info, arg_pseudo_type_info,
+ (arity + extra_args) * sizeof(Word));
+ /*
+ ** insert this type_info cell into the linked
+ ** list of allocated memory cells, so we can
+ ** free it later on
+ */
+ node = checked_malloc(sizeof(*node));
+ node->data = type_info;
+ node->next = *allocated;
+ *allocated = node;
+ }
+ type_info[i] = (Word) arg_type_info;
+ }
+ }
+ if (type_info == NULL) {
+ return arg_pseudo_type_info;
+ } else {
+ return type_info;
+ }
+
+} /* end MR_make_type_info() */
+
/*---------------------------------------------------------------------------*/
+
void mercury_sys_init_type_info(void); /* suppress gcc warning */
void mercury_sys_init_type_info(void) {
mercury__builtin_unify_pred_module();
Index: ../runtime/mercury_type_info.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.5
diff -u -r1.5 mercury_type_info.h
--- mercury_type_info.h 1998/03/11 05:58:46 1.5
+++ mercury_type_info.h 1998/05/01 05:43:07
@@ -779,5 +779,26 @@
#define MR_make_array(sz) ((MR_ArrayType *) make_many(Word, (sz) + 1))
+
+Word * MR_create_type_info(Word *, Word *);
+int MR_compare_type_info(Word, Word);
+Word MR_collapse_equivalences(Word);
+
+/*
+** definitions for creating type infos from pseudo_type_info's
+*/
+
+/* for make_type_info(), we keep a list of allocated memory cells */
+struct MR_MemoryCellNode {
+ void *data;
+ struct MR_MemoryCellNode *next;
+};
+typedef struct MR_MemoryCellNode *MR_MemoryList;
+
+Word * MR_make_type_info(Word *term_type_info, Word *arg_pseudo_type_info,
+ MR_MemoryList *allocated);
+void MR_deallocate(MR_MemoryList allocated_memory_cells);
+
+
/*---------------------------------------------------------------------------*/
#endif /* not MERCURY_TYPEINFO_H */
More information about the developers
mailing list