Tabling round 2 [2/2]
Oliver Hutchison
ohutch at students.cs.mu.OZ.AU
Fri Mar 13 16:53:17 AEDT 1998
Index: library/mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.93
diff -u -r1.93 mercury_builtin.m
--- mercury_builtin.m 1998/02/25 00:11:53 1.93
+++ mercury_builtin.m 1998/03/13 04:59:33
@@ -899,6 +899,769 @@
").
+:- interface.
+
+:- type table.
+
+ % This is a dummy predicate its pred_proc_id but not its code
+ % is used in compiler/table_gen.m see the comment there.
+:- impure pred get_table(table).
+:- mode get_table(out) is det.
+
+ % Return true if the subgoal represented by the given table is
+ % currently being evaluated (working on an answer).
+:- semipure pred table_working_on_ans(table).
+:- 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(table).
+:- 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(table).
+:- 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(table).
+:- mode table_mark_done_working(in) is det.
+
+
+ % Report an error message about the currernt subgoal looping.
+:- pred table_loopcheck_error is erroneous.
+
+ % Lookup or insert an integer in the given tri.
+:- 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 tri
+:- 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 tri.
+:- 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 tri.
+:- 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 tri.
+:- 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(table).
+:- mode table_have_ans(in) is semidet.
+
+ % 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(table).
+:- mode table_has_succeeded(in) is semidet.
+
+ % Save the fact the the subgoal has succeeded in the given table.
+:- impure pred table_mark_as_succeeded(table).
+:- 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(table).
+:- mode table_mark_as_failed(in) is failure.
+
+ % 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(table).
+:- 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(table, int, table).
+:- mode table_create_ans_block(in, in, out) is det.
+
+ % Save an integer answer in the given answer block at the given
+ % offset.
+:- impure pred table_save_int_ans(table, 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(table, 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(table, 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(table, 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(table, 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(table, 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(table, 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(table, 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(table, 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(table, int, T).
+:- mode table_restore_any_ans(in, in, out) is det.
+
+
+:- implementation.
+
+:- type table == c_pointer.
+
+:- pragma c_header_code("
+
+ /* Used to mark the status of the table */
+#define ML_UNINTIALISED 0
+#define ML_WORKING_ON_ANS 1
+#define ML_FAILED 2
+#define ML_SUCCEEDED 1024
+
+").
+
+
+ % This is a dummy procedure that never actualy gets called.
+ % See the comments in table_gen.m for its perpose.
+:- pragma c_code(get_table(T::out), will_not_call_mercury, "
+ /* Mention T so we avoid a warning */
+").
+
+:- 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_UNINTIALISED;
+").
+
+
+table_loopcheck_error :-
+ error("infinite recusion in loop_check procedure").
+
+
+:- 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;
+ SUCCESS_INDICATOR = FALSE;
+").
+
+
+:- 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);
+").
+
+
+:- interface.
+
+ % 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(table, table).
+:- mode table_setup(in, out) is det.
+
+ % Return all of the answer blocks stored in the given table.
+:- semipure pred table_return_all_ans(table, table).
+:- mode table_return_all_ans(in, out) is nondet.
+
+ % Return the table of answers already return to the given nondet
+ % table.
+:- impure pred table_get_ans_table(table, table).
+:- mode table_get_ans_table(in, out) is det.
+
+ % Return true if the given nondet table has returned all of its
+ % answers.
+:- semipure pred table_have_all_ans(table).
+:- mode table_have_all_ans(in) is semidet.
+
+ % Returns true if the given nondet table has returned some of its
+ % answers.
+:- semipure pred table_have_some_ans(table).
+:- mode table_have_some_ans(in) is semidet.
+
+
+ % Return true if the answer represented by the given answer
+ % table has been returned to its parent nondet table or not.
+:- semipure pred table_new_ans(table).
+:- mode table_new_ans(in) is semidet.
+
+ % Mark a nondet table as having some answers.
+:- impure pred table_mark_have_some_ans(table).
+:- mode table_mark_have_some_ans(in) is det.
+
+ % Make a nondet table as having all of its answers.
+:- impure pred table_mark_have_all_ans(table).
+:- mode table_mark_have_all_ans(in) is failure.
+
+ % Make the answer represented by the given answer table as
+ % having been return to its parent nondet table.
+:- impure pred table_mark_as_returned(table).
+:- mode table_mark_as_returned(in) is det.
+
+ % Suspend the current subgoal call.
+:- impure pred table_suspend(table, table).
+:- mode table_suspend(in, out) is nondet.
+
+ % Resume all suspended subgoal calls.
+:- impure pred table_resume(table).
+:- mode table_resume(in) is failure.
+
+
+ % Create a new slot in the answer list.
+:- impure pred table_new_ans_slot(table, table).
+:- mode table_new_ans_slot(in, out) is det.
+
+:- implementation.
+
+:- pragma c_header_code("
+
+typedef struct {
+ Word ans_num;
+ Word ans;
+} AnswerListNode;
+
+typedef struct {
+ Word *last_ret_ans;
+ Code *succ_ip;
+ Word *s_p;
+ Word *cur_fr;
+ Word *max_fr;
+ Word non_stack_block_size;
+ Word *non_stack_block;
+ Word det_stack_block_size;
+ Word *det_stack_block;
+} SuspendListNode;
+
+typedef enum {
+ have_no_ans,
+ have_some_ans,
+ have_all_ans
+} TableStatus;
+
+typedef struct {
+ TableStatus status;
+ Word answer_table;
+ Word num_ans;
+ Word answer_list;
+ Word *ans_list_tail;
+ Word suspend_list;
+ Word *suspend_list_tail;
+ Word *non_stack_bottom;
+ Word *det_stack_bottom;
+} NondetTable;
+
+ /* Flag used to indicate the answer has been returned */
+#define ML_ANS_NOT_RET 0
+#define ML_ANS_RET 1
+
+#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 = 0;
+ NON_TABLE(T0)->num_ans = 0;
+ NON_TABLE(T0)->answer_list = list_empty();
+ NON_TABLE(T0)->ans_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_new_ans(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;
+ SUCCESS_INDICATOR = 0;
+").
+
+:- 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;
+").
+
+
+:- pragma c_code(table_suspend(T::in, A::out), will_not_call_mercury, "
+ Word *non_stack_top = MR_maxfr;
+ Word *det_stack_top = MR_sp;
+ Word *non_stack_bottom = NON_TABLE(T)->non_stack_bottom;
+ Word *det_stack_bottom = NON_TABLE(T)->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(T)->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(T)->suspend_list_tail);
+ *NON_TABLE(T)->suspend_list_tail = ListNode;
+ NON_TABLE(T)->suspend_list_tail = &list_tail(ListNode);
+
+ A = 0;
+ fail();
+").
+
+:- external(table_resume/1).
+
+:- pragma c_code("
+
+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 = 256; /* Half the initial size of
+ the stack */
+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]
+
+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_module)
+ init_entry(mercury__table_resume_1_0);
+ init_label(mercury__table_resume_1_0_ChangeLoop);
+ init_label(mercury__table_resume_1_0_ChangeLoopDone);
+ init_label(mercury__table_resume_1_0_SolutionsListLoop);
+ init_label(mercury__table_resume_1_0_AnsListLoop);
+ init_label(mercury__table_resume_1_0_AnsListLoopDone);
+ init_label(mercury__table_resume_1_0_SkipAns);
+ init_label(mercury__table_resume_1_0_RedoPoint);
+BEGIN_CODE
+
+Define_entry(mercury__table_resume_1_0);
+ if (list_is_empty(NON_TABLE(r1)->answer_list) ||
+ list_is_empty(NON_TABLE(r1)->suspend_list))
+ {
+ SUCCESS_INDICATOR = FALSE;
+ proceed();
+ }
+
+ 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);
+
+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;
+
+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);
+
+ 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);
+
+Define_label(mercury__table_resume_1_0_AnsListLoop);
+ r1 = (Word) &ML_RESUME_VAR->ansNode->ans;
+
+ 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);
+ 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();
+
+ SUCCESS_INDICATOR = 0;
+ proceed();
+END_MODULE
+
+/* Ensure that the initialization code for the above module gets run. */
+/*
+INIT sys_init_table_module
+*/
+void sys_init_table_module(void);
+ /* extra declaration to suppress gcc -Wmissing-decl warning */
+void sys_init_table_module(void) {
+ extern ModuleFunc table_module;
+ table_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)->ans_list_tail);
+ *NON_TABLE(T)->ans_list_tail = ListNode;
+ NON_TABLE(T)->ans_list_tail = &list_tail(ListNode);
+
+ Slot = (Word)&n->ans;
+").
+
:- end_module mercury_builtin.
Index: library/std_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/std_util.m,v
retrieving revision 1.115
diff -u -r1.115 std_util.m
--- std_util.m 1998/01/30 02:15:04 1.115
+++ std_util.m 1998/03/11 04:47:24
@@ -957,131 +957,6 @@
****/
:- pragma c_header_code("
-
-#include ""mercury_type_info.h""
-
-int ML_compare_type_info(Word type_info_1, Word type_info_2);
-
-").
-
-:- pragma c_code("
-
-/*
-** ML_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
-ML_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 *) ML_collapse_equivalences(t1);
- type_info_2 = (Word *) ML_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 = ML_compare_type_info(
- arg_type_info_1, arg_type_info_2);
- if (comp != COMPARE_EQUAL)
- return comp;
- }
- return COMPARE_EQUAL;
-}
-
-").
-
-:- pragma c_header_code("
/*
** `univ' is represented as a two word structure.
** One word contains the address of a type_info for the type.
@@ -1123,7 +998,7 @@
Word univ_type_info = field(mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO);
int comp;
save_transient_registers();
- comp = ML_compare_type_info(univ_type_info, TypeInfo_for_T);
+ comp = MR_compare_type_info(univ_type_info, TypeInfo_for_T);
restore_transient_registers();
if (comp == COMPARE_EQUAL) {
Type = field(mktag(0), Univ, UNIV_OFFSET_FOR_DATA);
@@ -1221,7 +1096,7 @@
typeinfo1 = field(mktag(0), univ1, UNIV_OFFSET_FOR_TYPEINFO);
typeinfo2 = field(mktag(0), univ2, UNIV_OFFSET_FOR_TYPEINFO);
save_transient_registers();
- comp = ML_compare_type_info(typeinfo1, typeinfo2);
+ comp = MR_compare_type_info(typeinfo1, typeinfo2);
restore_transient_registers();
if (comp != COMPARE_EQUAL) {
unify_output = FALSE;
@@ -1266,7 +1141,7 @@
typeinfo1 = field(mktag(0), univ1, UNIV_OFFSET_FOR_TYPEINFO);
typeinfo2 = field(mktag(0), univ2, UNIV_OFFSET_FOR_TYPEINFO);
save_transient_registers();
- comp = ML_compare_type_info(typeinfo1, typeinfo2);
+ comp = MR_compare_type_info(typeinfo1, typeinfo2);
restore_transient_registers();
if (comp != COMPARE_EQUAL) {
compare_output = comp;
@@ -1320,7 +1195,7 @@
*/
int comp;
save_transient_registers();
- comp = ML_compare_type_info(unify_input1, unify_input2);
+ comp = MR_compare_type_info(unify_input1, unify_input2);
restore_transient_registers();
unify_output = (comp == COMPARE_EQUAL);
proceed();
@@ -1340,7 +1215,7 @@
*/
int comp;
save_transient_registers();
- comp = ML_compare_type_info(unify_input1, unify_input2);
+ comp = MR_compare_type_info(unify_input1, unify_input2);
restore_transient_registers();
compare_output = comp;
proceed();
@@ -1388,7 +1263,6 @@
Word term_vector);
bool ML_typecheck_arguments(Word type_info, int arity,
Word arg_list, Word* arg_vector);
-Word ML_collapse_equivalences(Word maybe_equiv_type_info);
Word ML_make_type(int arity, Word *base_type_info, Word arg_type_list);
").
@@ -1417,7 +1291,7 @@
*/
#if 0
save_transient_registers();
- TypeInfo = ML_collapse_equivalences(TypeInfo_for_T);
+ TypeInfo = MR_collapse_equivalences(TypeInfo_for_T);
restore_transient_registers();
#endif
@@ -1497,7 +1371,7 @@
Word *type_info, *base_type_info;
save_transient_registers();
- type_info = (Word *) ML_collapse_equivalences(TypeInfo);
+ type_info = (Word *) MR_collapse_equivalences(TypeInfo);
restore_transient_registers();
base_type_info = (Word *) MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
@@ -1555,7 +1429,7 @@
Integer arity;
save_transient_registers();
- type_info = (Word *) ML_collapse_equivalences(TypeInfo);
+ type_info = (Word *) MR_collapse_equivalences(TypeInfo);
base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
TypeCtor = ML_make_ctor_info(type_info, base_type_info);
@@ -1899,7 +1773,7 @@
equiv_type = (Word *) MR_TYPEFUNCTORS_EQUIV_TYPE(
base_type_functors);
return ML_get_functor_info((Word)
- ML_create_type_info((Word *) type_info,
+ MR_create_type_info((Word *) type_info,
equiv_type),
functor_number, info);
}
@@ -1945,10 +1819,10 @@
list_arg_type_info = field(0, list_head(arg_list),
UNIV_OFFSET_FOR_TYPEINFO);
- arg_type_info = (Word) ML_create_type_info(
+ arg_type_info = (Word) MR_create_type_info(
(Word *) type_info, (Word *) arg_vector[i]);
- comp = ML_compare_type_info(list_arg_type_info, arg_type_info);
+ comp = MR_compare_type_info(list_arg_type_info, arg_type_info);
if (comp != COMPARE_EQUAL) {
return FALSE;
}
@@ -2091,13 +1965,13 @@
/* Fill in any polymorphic type_infos */
save_transient_registers();
- argument = (Word) ML_create_type_info(
+ argument = (Word) MR_create_type_info(
(Word *) type_info, (Word *) argument);
restore_transient_registers();
/* Look past any equivalences */
save_transient_registers();
- argument = ML_collapse_equivalences(argument);
+ argument = MR_collapse_equivalences(argument);
restore_transient_registers();
/* Join the argument to the front of the list */
@@ -2108,40 +1982,6 @@
return type_info_list;
}
- /*
- ** ML_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
-ML_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) ML_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;
-}
/*
** ML_get_num_functors:
@@ -2180,7 +2020,7 @@
MR_TYPEFUNCTORS_EQUIV_TYPE(
base_type_functors);
Functors = ML_get_num_functors((Word)
- ML_create_type_info((Word *)
+ MR_create_type_info((Word *)
type_info, equiv_type));
break;
}
@@ -2254,8 +2094,6 @@
void ML_expand(Word* type_info, Word *data_word_ptr, ML_Expand_Info *info);
-Word * ML_create_type_info(Word *term_type_info, Word *arg_pseudo_type_info);
-
/* NB. ML_arg() is also used by store__arg_ref in store.m */
bool ML_arg(Word term_type_info, Word *term, Word argument_index,
Word *arg_type_info, Word **argument_ptr);
@@ -2300,6 +2138,9 @@
** If writing a C function that calls deep_copy, make sure you
** document that around your function, save_transient_registers()
** restore_transient_registers() need to be used.
+**
+** If you change this code you will also have reflect any changes in
+** runtime/mercury_deep_copy.c and runtime/mercury_table_any.c
*/
void
@@ -2374,7 +2215,7 @@
** Is it a type variable?
*/
if (TYPEINFO_IS_VARIABLE(entry_value)) {
- arg_type_info = ML_create_type_info(type_info,
+ arg_type_info = MR_create_type_info(type_info,
(Word *) entry_value);
ML_expand(arg_type_info, data_word_ptr, info);
}
@@ -2389,7 +2230,7 @@
** It must be an equivalent type.
*/
else {
- arg_type_info = ML_create_type_info(type_info,
+ arg_type_info = MR_create_type_info(type_info,
(Word *) MR_TYPELAYOUT_EQUIV_TYPE(
entry_value));
ML_expand(arg_type_info, data_word_ptr, info);
@@ -2475,7 +2316,7 @@
MR_TYPELAYOUT_SIMPLE_VECTOR_ARGS(
simple_vector)[i];
info->type_info_vector[i] = (Word)
- ML_create_type_info(type_info,
+ MR_create_type_info(type_info,
arg_pseudo_type_info);
}
}
@@ -2637,112 +2478,6 @@
}
- /*
- ** 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 make_type_info in runtime/deep_copy.c,
- ** which does much the same thing, only allocating using malloc
- ** instead of on the heap.
- */
-
-Word *
-ML_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(""ML_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 = ML_create_type_info(term_type_info,
- (Word *) arg_pseudo_type_info[i]);
- if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
- fatal_error(""ML_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;
- }
-}
/*
** ML_arg() is a subroutine used to implement arg/2, argument/2,
@@ -2860,7 +2595,7 @@
if (success) {
/* compare the actual type with the expected type */
comparison_result =
- ML_compare_type_info(arg_type_info, TypeInfo_for_ArgT);
+ MR_compare_type_info(arg_type_info, TypeInfo_for_ArgT);
success = (comparison_result == COMPARE_EQUAL);
if (success) {
Index: library/store.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/store.m,v
retrieving revision 1.12
diff -u -r1.12 store.m
--- store.m 1998/01/23 12:33:37 1.12
+++ store.m 1998/02/17 02:18:25
@@ -304,12 +304,12 @@
{ functor(Val, Functor, Arity) }.
:- pragma c_header_code("
+ #include ""mercury_type_info.h""
+
/* ML_arg() is defined in std_util.m */
bool ML_arg(Word term_type_info, Word *term, Word argument_index,
Word *arg_type_info, Word **argument_ptr);
- /* ML_compare_type_info() is defined in std_util.m */
- int ML_compare_type_info(Word type_info_1, Word type_info_2);
").
:- pragma c_code(arg_ref(Ref::in, ArgNum::in, ArgRef::out, S0::di, S::uo),
@@ -326,7 +326,7 @@
fatal_error(""store__arg_ref: argument number out of range"");
}
- if (ML_compare_type_info(arg_type_info, TypeInfo_for_ArgT) !=
+ if (MR_compare_type_info(arg_type_info, TypeInfo_for_ArgT) !=
COMPARE_EQUAL)
{
fatal_error(""store__arg_ref: argument has wrong type"");
@@ -352,7 +352,7 @@
fatal_error(""store__new_arg_ref: argument number out of range"");
}
- if (ML_compare_type_info(arg_type_info, TypeInfo_for_ArgT) !=
+ if (MR_compare_type_info(arg_type_info, TypeInfo_for_ArgT) !=
COMPARE_EQUAL)
{
fatal_error(""store__new_arg_ref: argument has wrong type"");
Index: runtime/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/Mmakefile,v
retrieving revision 1.22
diff -u -r1.22 Mmakefile
--- Mmakefile 1998/03/11 05:58:21 1.22
+++ Mmakefile 1998/03/13 00:55:39
@@ -14,7 +14,7 @@
#-----------------------------------------------------------------------------#
CFLAGS = -I$(MERCURY_DIR)/runtime -I$(MERCURY_DIR)/boehm_gc -g \
- $(DLL_CFLAGS) $(EXTRA_CFLAGS)
+ $(DLL_CFLAGS) $(EXTRA_CFLAGS)
MGNUC = MERCURY_C_INCL_DIR=. $(SCRIPTS_DIR)/mgnuc
MGNUCFLAGS = --no-ansi $(EXTRA_MGNUCFLAGS) $(CFLAGS)
MOD2C = $(SCRIPTS_DIR)/mod2c
@@ -55,6 +55,11 @@
mercury_stack_trace.h \
mercury_string.h \
mercury_table.h \
+ mercury_table_any.h \
+ mercury_table_enum.h \
+ mercury_table_int_float_string.h \
+ mercury_table_type_info.h\
+ mercury_tabling.h \
mercury_tags.h \
mercury_timing.h \
mercury_trace.h \
@@ -97,6 +102,10 @@
mercury_spinlock.c \
mercury_stack_trace.c \
mercury_table.c \
+ mercury_table_any.c \
+ mercury_table_enum.c \
+ mercury_table_int_float_string.c\
+ mercury_table_type_info.c\
mercury_timing.c \
mercury_trace.c \
mercury_trail.c \
Index: runtime/mercury_deep_copy.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_deep_copy.c,v
retrieving revision 1.4
diff -u -r1.4 mercury_deep_copy.c
--- mercury_deep_copy.c 1997/12/30 16:06:04 1.4
+++ mercury_deep_copy.c 1998/03/11 04:49:31
@@ -40,6 +40,9 @@
** deep_copy(): see mercury_deep_copy.h for documentation.
**
** Due to the depth of the control here, we'll use 4 space indentation.
+**
+** NOTE : changes to this function will probably also have to be reflected
+** in the function std_util::ML_expand() and mercury_table_any.c
*/
Word
deep_copy(Word data, Word *type_info, Word *lower_limit, Word *upper_limit)
Index: runtime/mercury_deep_copy.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_deep_copy.h,v
retrieving revision 1.2
diff -u -r1.2 mercury_deep_copy.h
--- mercury_deep_copy.h 1997/11/23 07:21:17 1.2
+++ mercury_deep_copy.h 1998/03/11 04:48:03
@@ -57,6 +57,7 @@
** you document that around your function,
** save_transient_registers()/restore_transient_registers()
** need to be used.
+**
*/
Word deep_copy(Word data, Word *type_info, Word *lower_limit,
Index: runtime/mercury_imp.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_imp.h,v
retrieving revision 1.5
diff -u -r1.5 mercury_imp.h
--- mercury_imp.h 1998/03/11 05:58:33 1.5
+++ mercury_imp.h 1998/03/12 01:49:02
@@ -67,6 +67,7 @@
#include "mercury_prof.h"
#include "mercury_misc.h"
+#include "mercury_tabling.h"
#include "mercury_grade.h"
Index: runtime/mercury_string.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_string.h,v
retrieving revision 1.8
diff -u -r1.8 mercury_string.h
--- mercury_string.h 1998/02/03 08:17:22 1.8
+++ mercury_string.h 1998/03/11 04:13:27
@@ -124,10 +124,10 @@
int hash_string(Word);
#ifdef __GNUC__
-#define hash_string(s) \
- ({ int hash; \
- do_hash_string(hash, s); \
- hash; \
+#define hash_string(s) \
+ ({ int hash_string_result; \
+ do_hash_string(hash_string_result, s); \
+ hash_string_result; \
})
#endif
@@ -137,8 +137,8 @@
*/
#define HASH_STRING_FUNC_BODY \
- int hash; \
- do_hash_string(hash, s); \
- return hash;
+ int _hash; \
+ do_hash_string(_hash, s); \
+ return _hash;
#endif /* not MERCURY_STRING_H */
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/02/17 02:20:13
@@ -151,6 +151,260 @@
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 make_type_info in runtime/deep_copy.c,
+ ** 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;
+}
/*---------------------------------------------------------------------------*/
void mercury_sys_init_type_info(void); /* suppress gcc warning */
void mercury_sys_init_type_info(void) {
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/03/12 01:49:05
@@ -779,5 +779,10 @@
#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);
+
/*---------------------------------------------------------------------------*/
#endif /* not MERCURY_TYPEINFO_H */
More information about the developers
mailing list