Tabling [2/3]
Oliver Hutchison
ohutch at students.cs.mu.OZ.AU
Mon Mar 9 17:56:39 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/02 03:17:08
@@ -899,6 +899,729 @@
").
+:- interface.
+:- import_module char.
+
+:- type table.
+
+
+:- impure pred get_table(table).
+:- mode get_table(out) is det.
+
+
+:- semipure pred table_working_on_ans(table).
+:- mode table_working_on_ans(in) is semidet.
+
+:- impure pred table_mark_as_working(table).
+:- mode table_mark_as_working(in) is det.
+
+:- impure pred table_loopcheck_error is erroneous.
+
+
+:- impure pred table_lookup_insert_int(table, int, table).
+:- mode table_lookup_insert_int(in, in, out) is det.
+
+:- impure pred table_lookup_insert_char(table, char, table).
+:- mode table_lookup_insert_char(in, in, out) is det.
+
+:- impure pred table_lookup_insert_string(table, string, table).
+:- mode table_lookup_insert_string(in, in, out) is det.
+
+:- impure pred table_lookup_insert_float(table, float, table).
+:- mode table_lookup_insert_float(in, in, out) is det.
+
+:- impure pred table_lookup_insert_enum(table, int, T, table).
+:- mode table_lookup_insert_enum(in, in, in, out) is det.
+
+:- impure pred table_lookup_insert_user(table, T, table).
+:- mode table_lookup_insert_user(in, in, out) is det.
+
+:- impure pred table_lookup_insert_poly(table, T, table).
+:- mode table_lookup_insert_poly(in, in, out) is det.
+
+
+:- semipure pred table_have_ans(table).
+:- mode table_have_ans(in) is semidet.
+
+:- semipure pred table_has_failed(table).
+:- mode table_has_failed(in) is semidet.
+
+
+:- impure pred table_create_ans_block(table, int, table).
+:- mode table_create_ans_block(in, in, out) is det.
+
+:- impure pred table_save_int_ans(table, int, int).
+:- mode table_save_int_ans(in, in, in) is det.
+
+:- impure pred table_save_char_ans(table, int, char).
+:- mode table_save_char_ans(in, in, in) is det.
+
+:- impure pred table_save_string_ans(table, int, string).
+:- mode table_save_string_ans(in, in, in) is det.
+
+:- impure pred table_save_float_ans(table, int, float).
+:- mode table_save_float_ans(in, in, in) is det.
+
+:- impure pred table_save_any_ans(table, int, T).
+:- mode table_save_any_ans(in, in, in) is det.
+
+:- impure pred table_save_failure(table).
+:- mode table_save_failure(in) is det.
+
+
+:- semipure pred table_restore_int_ans(table, int, int).
+:- mode table_restore_int_ans(in, in, out) is det.
+
+:- semipure pred table_restore_char_ans(table, int, char).
+:- mode table_restore_char_ans(in, in, out) is det.
+
+:- semipure pred table_restore_string_ans(table, int, string).
+:- mode table_restore_string_ans(in, in, out) is det.
+
+:- semipure pred table_restore_float_ans(table, int, float).
+:- mode table_restore_float_ans(in, in, out) is det.
+
+:- 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("
+
+#define ML_WORKING_ON_ANS 1
+#define ML_FAILED 2
+
+").
+
+
+:- pragma c_code(get_table(T::out), "
+ T = 0;
+").
+
+:- pragma c_code(table_working_on_ans(T::in), "
+ TABLE_PROFILE_CALL(WorkingOnAns);
+ if (*((Word*) T) == ML_WORKING_ON_ANS) {
+ SUCCESS_INDICATOR = 1;
+ } else {
+ SUCCESS_INDICATOR = 0;
+ }
+").
+
+:- pragma c_code(table_mark_as_working(T::in), "
+ TABLE_PROFILE_CALL(MarkWorkingOnAns);
+ *((Word*) T) = ML_WORKING_ON_ANS;
+").
+
+:- pragma c_code(table_loopcheck_error, "
+ exit(-1);
+").
+
+:- pragma c_code(table_lookup_insert_int(T0::in, I::in, T::out), "
+ TABLE_PROFILE_CALL(LookupInsertInt);
+ T = (Word)MR_TABLE_INT((Word**)T0, I);
+").
+
+:- pragma c_code(table_lookup_insert_char(T0::in, C::in, T::out), "
+ TABLE_PROFILE_CALL(LookupInsertChar);
+ T = (Word)MR_TABLE_CHAR((Word**)T0, C);
+").
+
+:- pragma c_code(table_lookup_insert_string(T0::in, S::in, T::out), "
+ TABLE_PROFILE_CALL(LookupInsertString);
+ T = (Word)MR_TABLE_STRING((Word**)T0, S);
+").
+
+:- pragma c_code(table_lookup_insert_float(T0::in, F::in, T::out), "
+ TABLE_PROFILE_CALL(LookupInsertFloat);
+ T = (Word)MR_TABLE_FLOAT((Word**)T0, F);
+").
+
+:- pragma c_code(table_lookup_insert_enum(T0::in, R::in, V::in, T::out), "
+ TABLE_PROFILE_CALL(LookupInsertEnum);
+ T = (Word)MR_TABLE_ENUM((Word**)T0, R, V);
+").
+
+:- pragma c_code(table_lookup_insert_user(T0::in, V::in, T::out), "
+ TABLE_PROFILE_CALL(LookupInsertUser);
+ T = (Word)MR_TABLE_ANY((Word**)T0, TypeInfo_for_T, V);
+").
+
+:- pragma c_code(table_lookup_insert_poly(T0::in, V::in, T::out), "
+ Word T1 = (Word)MR_TABLE_TYPE_INFO((Word**)T0, TypeInfo_for_T);
+ TABLE_PROFILE_CALL(LookupInsertPoly);
+ T = (Word)MR_TABLE_ANY((Word**)T1, TypeInfo_for_T, V);
+").
+
+:- pragma c_code(table_have_ans(T::in), "
+ TABLE_PROFILE_CALL(HaveAns);
+ if (*((Word*) T)) {
+ SUCCESS_INDICATOR = 1;
+ } else {
+ SUCCESS_INDICATOR = 0;
+ }
+").
+
+:- pragma c_code(table_has_failed(T::in), "
+ TABLE_PROFILE_CALL(HasFailed);
+ if (*((Word*) T) == ML_FAILED) {
+ SUCCESS_INDICATOR = 1;
+ } else {
+ SUCCESS_INDICATOR = 0;
+ }
+").
+
+:- pragma c_code(table_create_ans_block(T0::in, Size::in, T::out) ,"
+ TABLE_PROFILE_CALL(CreateAnsBlock);
+ MR_TABLE_CREATE_ANSWER_BLOCK(T0, Size);
+ T = T0;
+").
+
+:- pragma c_code(table_save_int_ans(T::in, Offset::in, I::in), "
+ TABLE_PROFILE_CALL(SaveIntAns);
+ 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), "
+ TABLE_PROFILE_CALL(SaveCharAns);
+ 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), "
+ TABLE_PROFILE_CALL(SaveStringAns);
+ 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), "
+ TABLE_PROFILE_CALL(SaveFloatAns);
+ 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), "
+ TABLE_PROFILE_CALL(SaveAnyAns);
+ MR_TABLE_SAVE_ANSWER(Offset, T, V, TypeInfo_for_T);
+").
+
+:- pragma c_code(table_save_failure(T::in), "
+ TABLE_PROFILE_CALL(SaveFailure);
+ *((Word*) T) = ML_FAILED;
+").
+
+
+:- pragma c_code(table_restore_int_ans(T::in, Offset::in, I::out), "
+ TABLE_PROFILE_CALL(RestoreInt);
+ I = (Integer)MR_TABLE_GET_ANSWER(Offset, T);
+").
+
+:- pragma c_code(table_restore_char_ans(T::in, Offset::in, C::out), "
+ TABLE_PROFILE_CALL(RestoreChar);
+ C = (Char)MR_TABLE_GET_ANSWER(Offset, T);
+").
+
+:- pragma c_code(table_restore_string_ans(T::in, Offset::in, S::out), "
+ TABLE_PROFILE_CALL(RestoreString);
+ S = (String)MR_TABLE_GET_ANSWER(Offset, T);
+").
+
+:- pragma c_code(table_restore_float_ans(T::in, Offset::in, F::out), "
+ TABLE_PROFILE_CALL(RestoreFloat);
+ F = word_to_float(MR_TABLE_GET_ANSWER(Offset, T));
+").
+
+:- pragma c_code(table_restore_any_ans(T::in, Offset::in, V::out), "
+ TABLE_PROFILE_CALL(RestoreAny);
+ V = (Word)MR_TABLE_GET_ANSWER(Offset, T);
+").
+
+
+:- interface.
+
+:- impure pred table_setup(table, table).
+:- mode table_setup(in, out) is det.
+
+:- semipure pred table_return_all_ans(table, table).
+:- mode table_return_all_ans(in, out) is nondet.
+
+:- impure pred table_get_ans_table(table, table).
+:- mode table_get_ans_table(in, out) is det.
+
+
+:- semipure pred table_have_all_ans(table).
+:- mode table_have_all_ans(in) is semidet.
+
+:- semipure pred table_have_some_ans(table).
+:- mode table_have_some_ans(in) is semidet.
+
+:- semipure pred table_new_ans(table).
+:- mode table_new_ans(in) is semidet.
+
+
+:- impure pred table_mark_have_some_ans(table).
+:- mode table_mark_have_some_ans(in) is det.
+
+:- impure pred table_mark_have_all_ans(table).
+:- mode table_mark_have_all_ans(in) is failure.
+
+:- impure pred table_mark_as_returned(table).
+:- mode table_mark_as_returned(in) is det.
+
+
+:- impure pred table_suspend(table, table).
+:- mode table_suspend(in, out) is nondet.
+
+:- impure pred table_resume(table).
+:- mode table_resume(in) is failure.
+
+
+:- 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 AnsNum;
+ Word Ans;
+} AnswerListNode;
+
+typedef struct {
+ Word *LastRetAns;
+ Code *SuccIP;
+ Word *SP;
+ Word *CurFr;
+ Word *MaxFr;
+ Word NonStackBlockSize;
+ Word *NonStackBlock;
+ Word DetStackBlockSize;
+ Word *DetStackBlock;
+} SuspendListNode;
+
+typedef struct {
+ Word TableNum;
+ Word Status;
+ Word AnswerTable;
+ Word NumAns;
+ Word AnswerList;
+ Word *AnswerListTail;
+ Word SuspendList;
+ Word *SuspendListTail;
+ Word *NonStackBottom;
+ Word *DetStackBottom;
+} NondetTable;
+
+#define ML_HAVE_NO_ANS 0
+#define ML_HAVE_ALL_ANS 1
+#define ML_HAVE_SOME_ANS 2
+
+#define ML_ANS_USED 1
+
+#ifdef MR_TABLE_DEBUG
+void dump_table(NondetTable *);
+#else
+#define dump_table(A)
+#endif
+
+extern Word NumTables;
+
+
+#define NON_TABLE(T) (*((NondetTable **)T))
+").
+
+
+:- pragma c_code(table_setup(T0::in, T::out), "
+ /* Init the table if this is the first time me see it */
+ if (NON_TABLE(T0) == NULL) {
+ TABLE_PROFILE_CALL(Setup);
+ NON_TABLE(T0) = (NondetTable *) table_allocate(
+ sizeof(NondetTable));
+ NON_TABLE(T0)->TableNum = ++NumTables;
+ NON_TABLE(T0)->Status = ML_HAVE_NO_ANS;
+ NON_TABLE(T0)->AnswerTable = 0;
+ NON_TABLE(T0)->NumAns = 0;
+ NON_TABLE(T0)->AnswerList = list_empty();
+ NON_TABLE(T0)->AnswerListTail =
+ &NON_TABLE(T0)->AnswerList;
+ NON_TABLE(T0)->SuspendList = list_empty();
+ NON_TABLE(T0)->SuspendListTail =
+ &NON_TABLE(T0)->SuspendList;
+ NON_TABLE(T0)->NonStackBottom = curprevfr;
+ NON_TABLE(T0)->DetStackBottom = MR_sp;
+ }
+ dump_table(NON_TABLE(T0));
+ T = T0;
+").
+
+
+table_return_all_ans(T, A) :-
+ semipure table_return_all_ans_list(T, AList),
+ list__member(Node, AList),
+ semipure table_return_all_ans2(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), "
+ TABLE_PROFILE_CALL(RetAllAns);
+ A = NON_TABLE(T)->AnswerList;
+").
+
+:- semipure pred table_return_all_ans2(table, table).
+:- mode table_return_all_ans2(in, out) is det.
+
+:- pragma c_code(table_return_all_ans2(P::in, A::out), "
+ A = (Word) &((AnswerListNode*) P)->Ans;
+").
+
+:- pragma c_code(table_get_ans_table(T::in, AT::out), "
+ TABLE_PROFILE_CALL(GenAnsTable);
+ AT = (Word) &(NON_TABLE(T)->AnswerTable);
+").
+
+:- pragma c_code(table_have_all_ans(T::in),"
+ TABLE_PROFILE_CALL(HaveAllAns);
+ if (NON_TABLE(T)->Status == ML_HAVE_ALL_ANS) {
+ SUCCESS_INDICATOR = 1;
+ } else {
+ SUCCESS_INDICATOR = 0;
+ }
+").
+
+:- pragma c_code(table_have_some_ans(T::in), "
+ TABLE_PROFILE_CALL(HaveSomeAns);
+ if (NON_TABLE(T)->Status == ML_HAVE_SOME_ANS) {
+ SUCCESS_INDICATOR = 1;
+ } else {
+ SUCCESS_INDICATOR = 0;
+ }
+").
+
+:- pragma c_code(table_new_ans(T::in), "
+ TABLE_PROFILE_CALL(NewAns);
+ if (*((Word*) T) == ML_ANS_USED) {
+ SUCCESS_INDICATOR = 0;
+ } else {
+ SUCCESS_INDICATOR = 1;
+ }
+").
+
+
+
+:- pragma c_code(table_mark_have_all_ans(T::in), "
+ TABLE_PROFILE_CALL(MarkHaveAllAns);
+ dump_table(NON_TABLE(T));
+ NON_TABLE(T)->Status = ML_HAVE_ALL_ANS;
+ SUCCESS_INDICATOR = 0;
+").
+
+:- pragma c_code(table_mark_have_some_ans(T::in), "
+ TABLE_PROFILE_CALL(MarkHaveSomeAns);
+ NON_TABLE(T)->Status = ML_HAVE_SOME_ANS;
+").
+
+:- pragma c_code(table_mark_as_returned(T::in), "
+ TABLE_PROFILE_CALL(MarkAsReturned);
+ *((Word *) T) = ML_ANS_USED;
+").
+
+
+:- pragma c_code(table_suspend(T::in, A::out), "
+ Word *non_stack_top = MR_maxfr;
+ Word *det_stack_top = MR_sp;
+ Word *non_stack_bottom = NON_TABLE(T)->NonStackBottom;
+ Word *det_stack_bottom = NON_TABLE(T)->DetStackBottom;
+ Word non_stack_delta = (Word) non_stack_top - (Word) non_stack_bottom;
+ Word det_stack_delta = (Word) det_stack_top - (Word) det_stack_bottom;
+ Word ListNode;
+ SuspendListNode *Node = pool_allocate(sizeof(SuspendListNode));
+
+ TABLE_PROFILE_CALL(Suspend);
+
+ dump_table(NON_TABLE(T));
+
+ Node->LastRetAns = &(NON_TABLE(T)->AnswerList);
+
+ Node->NonStackBlockSize = non_stack_delta;
+ Node->NonStackBlock = table_allocate(non_stack_delta);
+ table_copy_mem((void *)Node->NonStackBlock, (void *)non_stack_bottom,
+ non_stack_delta);
+
+ Node->DetStackBlockSize = det_stack_delta;
+ Node->DetStackBlock = table_allocate(det_stack_delta);
+ table_copy_mem((void *)Node->DetStackBlock, (void *)det_stack_bottom,
+ det_stack_delta);
+
+ Node->SuccIP = MR_succip;
+ Node->SP = MR_sp;
+ Node->CurFr = MR_curfr;
+ Node->MaxFr = MR_maxfr;
+
+ ListNode = list_cons(Node, *NON_TABLE(T)->SuspendListTail);
+ *NON_TABLE(T)->SuspendListTail = ListNode;
+ NON_TABLE(T)->SuspendListTail = &list_tail(ListNode);
+
+ A = 0;
+ fail();
+").
+
+:- external(table_resume/1).
+
+:- pragma c_code("
+
+typedef struct {
+ NondetTable *Table;
+ Word NonStackBlockSize;
+ Word *NonStackBlock;
+ Word DetStackBlockSize;
+ Word *DetStackBlock;
+
+ Code *SuccIP;
+ Word *SP;
+ Word *CurFr;
+ Word *MaxFr;
+
+ Word changed;
+ Word NumAns, NewNumAns;
+ Word SList;
+ SuspendListNode *SuspendNode;
+ Word AList;
+ AnswerListNode *AnsNode;
+} ResumeStackNode;
+
+Integer ML_resumption_SP = -1;
+Word ML_resumption_stack_size = 256; /* Half the inital 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(ChangeLoop);
+Declare_label(ChangeLoopDone);
+Declare_label(SolutionsListLoop);
+Declare_label(AnsListLoop);
+Declare_label(AnsListLoopDone);
+Declare_label(SkipAns);
+Declare_label(RedoPoint);
+
+MR_MAKE_STACK_LAYOUT_ENTRY(mercury__table_resume_1_0);
+
+BEGIN_MODULE(table_module)
+ init_entry(mercury__table_resume_1_0);
+ init_label(ChangeLoop);
+ init_label(ChangeLoopDone);
+ init_label(SolutionsListLoop);
+ init_label(AnsListLoop);
+ init_label(AnsListLoopDone);
+ init_label(SkipAns);
+ init_label(RedoPoint);
+BEGIN_CODE
+
+
+
+Define_entry(mercury__table_resume_1_0);
+
+ dump_table(NON_TABLE(r1));
+
+ if (list_is_empty(NON_TABLE(r1)->AnswerList) ||
+ list_is_empty(NON_TABLE(r1)->SuspendList))
+ {
+ SUCCESS_INDICATOR = 0;
+ proceed();
+ }
+
+ ML_RESUME_PUSH();
+
+ ML_RESUME_VAR->Table = NON_TABLE(r1);
+ ML_RESUME_VAR->NonStackBlockSize = (Word) MR_maxfr -
+ (Word) ML_RESUME_VAR->Table->NonStackBottom;
+ ML_RESUME_VAR->DetStackBlockSize = (Word) MR_sp -
+ (Word )ML_RESUME_VAR->Table->DetStackBottom;
+ ML_RESUME_VAR->SuccIP = MR_succip;
+ ML_RESUME_VAR->SP = MR_sp;
+ ML_RESUME_VAR->CurFr = MR_curfr;
+ ML_RESUME_VAR->MaxFr = MR_maxfr;
+
+ ML_RESUME_VAR->changed = 1;
+
+ ML_RESUME_VAR->NonStackBlock = (Word *) table_allocate(
+ ML_RESUME_VAR->NonStackBlockSize);
+ table_copy_mem(ML_RESUME_VAR->NonStackBlock,
+ ML_RESUME_VAR->Table->NonStackBottom,
+ ML_RESUME_VAR->NonStackBlockSize);
+
+ ML_RESUME_VAR->DetStackBlock = (Word *) table_allocate(
+ ML_RESUME_VAR->DetStackBlockSize);
+ table_copy_mem(ML_RESUME_VAR->DetStackBlock,
+ ML_RESUME_VAR->Table->DetStackBottom,
+ ML_RESUME_VAR->DetStackBlockSize);
+
+Define_label(ChangeLoop);
+ if (! ML_RESUME_VAR->changed)
+ GOTO_LABEL(ChangeLoopDone);
+
+ ML_RESUME_VAR->SList = ML_RESUME_VAR->Table->SuspendList;
+
+ ML_RESUME_VAR->changed = 0;
+ ML_RESUME_VAR->NumAns = ML_RESUME_VAR->Table->NumAns;
+
+Define_label(SolutionsListLoop);
+ if (list_is_empty(ML_RESUME_VAR->SList))
+ GOTO_LABEL(ChangeLoop);
+
+ ML_RESUME_VAR->SuspendNode = (SuspendListNode *)list_head(
+ ML_RESUME_VAR->SList);
+
+ ML_RESUME_VAR->AList = *ML_RESUME_VAR->SuspendNode->
+ LastRetAns;
+
+ if (list_is_empty(ML_RESUME_VAR->AList))
+ GOTO_LABEL(AnsListLoopDone2);
+
+ ML_RESUME_VAR->AnsNode = (AnswerListNode *)list_head(
+ ML_RESUME_VAR->AList);
+
+ table_copy_mem(ML_RESUME_VAR->Table->NonStackBottom,
+ ML_RESUME_VAR->SuspendNode->NonStackBlock,
+ ML_RESUME_VAR->SuspendNode->NonStackBlockSize);
+
+ table_copy_mem(ML_RESUME_VAR->Table->DetStackBottom,
+ ML_RESUME_VAR->SuspendNode->DetStackBlock,
+ ML_RESUME_VAR->SuspendNode->DetStackBlockSize);
+
+ MR_succip = ML_RESUME_VAR->SuspendNode->SuccIP;
+ MR_sp = ML_RESUME_VAR->SuspendNode->SP;
+ MR_curfr = ML_RESUME_VAR->SuspendNode->CurFr;
+ MR_maxfr = ML_RESUME_VAR->SuspendNode->MaxFr;
+
+ bt_redoip(maxfr) = LABEL(RedoPoint);
+
+Define_label(AnsListLoop);
+ r1 = (Word) &ML_RESUME_VAR->AnsNode->Ans;
+
+ TABLE_PROFILE_CALL(Resume);
+
+ succeed();
+
+Define_label(RedoPoint);
+ update_prof_current_proc(LABEL(mercury__table_resume_1_0));
+
+ ML_RESUME_VAR->AList = list_tail(ML_RESUME_VAR->AList);
+
+ if (list_is_empty(ML_RESUME_VAR->AList))
+ GOTO_LABEL(AnsListLoopDone1);
+
+ ML_RESUME_VAR->AnsNode = (AnswerListNode *)list_head(
+ ML_RESUME_VAR->AList);
+
+ GOTO_LABEL(AnsListLoop);
+
+Define_label(AnsListLoopDone1);
+ if (ML_RESUME_VAR->NumAns == ML_RESUME_VAR->Table->NumAns) {
+ ML_RESUME_VAR->changed = 0;
+ } else {
+ ML_RESUME_VAR->changed = 1;
+ }
+
+ ML_RESUME_VAR->SuspendNode->LastRetAns =
+ &ML_RESUME_VAR->AList;
+
+Define_label(AnsListLoopDone2);
+ ML_RESUME_VAR->SList = list_tail(ML_RESUME_VAR->SList);
+ GOTO_LABEL(SolutionsListLoop);
+
+Define_label(SkipAns);
+ ML_RESUME_VAR->AList = list_tail(ML_RESUME_VAR->AList);
+ GOTO_LABEL(AnsListLoop);
+
+Define_label(ChangeLoopDone);
+ table_copy_mem(ML_RESUME_VAR->Table->NonStackBottom,
+ ML_RESUME_VAR->NonStackBlock,
+ ML_RESUME_VAR->NonStackBlockSize);
+ table_free(ML_RESUME_VAR->NonStackBlock);
+
+ table_copy_mem(ML_RESUME_VAR->Table->DetStackBottom,
+ ML_RESUME_VAR->DetStackBlock,
+ ML_RESUME_VAR->DetStackBlockSize);
+ table_free(ML_RESUME_VAR->DetStackBlock);
+
+ MR_succip = ML_RESUME_VAR->SuccIP;
+ MR_sp = ML_RESUME_VAR->SP;
+ MR_curfr = ML_RESUME_VAR->CurFr;
+ MR_maxfr = ML_RESUME_VAR->MaxFr;
+
+ 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), "
+ Word ListNode;
+ Word AnsNum;
+ AnswerListNode *n = pool_allocate(sizeof(AnswerListNode));
+
+ dump_table(NON_TABLE(T));
+ TABLE_PROFILE_CALL(NewAnsSlot);
+
+ ++(NON_TABLE(T)->NumAns);
+ AnsNum = NON_TABLE(T)->NumAns;
+ n->AnsNum = AnsNum;
+ n->Ans = 0;
+ ListNode = list_cons(n, *NON_TABLE(T)->AnswerListTail);
+ *NON_TABLE(T)->AnswerListTail = ListNode;
+ NON_TABLE(T)->AnswerListTail = &list_tail(ListNode);
+
+ Slot = (Word)&n->Ans;
+ dump_table(NON_TABLE(T));
+").
+
:- 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/05 23:51:30
@@ -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);
@@ -2374,7 +2212,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 +2227,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 +2313,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 +2475,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 +2592,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.21
diff -u -r1.21 Mmakefile
--- Mmakefile 1997/12/05 15:56:25 1.21
+++ Mmakefile 1998/03/02 03:28:44
@@ -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 $(CFLAGS)
MOD2C = $(SCRIPTS_DIR)/mod2c
@@ -53,6 +53,12 @@
mercury_stacks.h \
mercury_string.h \
mercury_table.h \
+ mercury_table_any.h \
+ mercury_table_enum.h \
+ mercury_table_int_float_string.h \
+ mercury_table_profile.h \
+ mercury_table_type_info.h\
+ mercury_tabling.h \
mercury_tags.h \
mercury_timing.h \
mercury_trace.h \
@@ -94,6 +100,11 @@
mercury_regs.c \
mercury_spinlock.c \
mercury_table.c \
+ mercury_table_any.c \
+ mercury_table_enum.c \
+ mercury_table_int_float_string.c\
+ mercury_table_profile.c \
+ mercury_table_type_info.c\
mercury_timing.c \
mercury_trace.c \
mercury_trail.c \
Index: runtime/mercury_imp.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_imp.h,v
retrieving revision 1.4
diff -u -r1.4 mercury_imp.h
--- mercury_imp.h 1997/12/05 15:56:38 1.4
+++ mercury_imp.h 1998/03/03 08:27:53
@@ -65,6 +65,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/02/17 02:20:12
@@ -125,9 +125,9 @@
#ifdef __GNUC__
#define hash_string(s) \
- ({ int hash; \
- do_hash_string(hash, s); \
- hash; \
+ ({ int _hash; \
+ do_hash_string(_hash, s); \
+ _hash; \
})
#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.4
diff -u -r1.4 mercury_type_info.h
--- mercury_type_info.h 1998/01/23 12:12:05 1.4
+++ mercury_type_info.h 1998/02/17 02:20:13
@@ -790,5 +790,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