From 37a49f2135f1b76cfa3fa20492b9e5d6bc7bb89d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:15:17 +0100 Subject: [PATCH 01/25] synchronize compiler oops with their descriptions computils; allocate N instruction blocks. --- C/computils.c | 553 +++++++++++++++----------------------------------- H/compile.h | 396 +++++++++++++++++++----------------- 2 files changed, 374 insertions(+), 575 deletions(-) diff --git a/C/computils.c b/C/computils.c index 2396709fb..d6ae74e30 100644 --- a/C/computils.c +++ b/C/computils.c @@ -66,9 +66,6 @@ static char SccsId[] = "%W% %G%"; #include #endif -#ifdef DEBUG -static void ShowOp(const char *, struct PSEUDO *); -#endif /* DEBUG */ /* * The compiler creates an instruction chain which will be assembled after @@ -288,6 +285,72 @@ Yap_emit_4ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, struct inte } } +void +Yap_emit_5ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, struct intermediates *cip) +{ + PInstr *p; + p = (PInstr *) AllocCMem (sizeof (*p)+3*sizeof(CELL), cip); + p->op = o; + p->rnd1 = r1; + p->rnd2 = r2; + p->rnd3 = r3; + p->rnd4 = r4; + p->rnd5 = r5; + p->nextInst = NIL; + if (cip->cpc == NIL) + cip->cpc = cip->CodeStart = p; + else + { + cip->cpc->nextInst = p; + cip->cpc = p; + } +} + +void +Yap_emit_6ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, CELL r6, struct intermediates *cip) +{ + PInstr *p; + p = (PInstr *) AllocCMem (sizeof (*p)+4*sizeof(CELL), cip); + p->op = o; + p->rnd1 = r1; + p->rnd2 = r2; + p->rnd3 = r3; + p->rnd4 = r4; + p->rnd5 = r5; + p->rnd6 = r6; + p->nextInst = NIL; + if (cip->cpc == NIL) + cip->cpc = cip->CodeStart = p; + else + { + cip->cpc->nextInst = p; + cip->cpc = p; + } +} + +void +Yap_emit_7ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, CELL r6, CELL r7, struct intermediates *cip) +{ + PInstr *p; + p = (PInstr *) AllocCMem (sizeof (*p)+5*sizeof(CELL), cip); + p->op = o; + p->rnd1 = r1; + p->rnd2 = r2; + p->rnd3 = r3; + p->rnd4 = r4; + p->rnd5 = r5; + p->rnd6 = r6; + p->rnd7 = r7; + p->nextInst = NIL; + if (cip->cpc == NIL) + cip->cpc = cip->CodeStart = p; + else + { + cip->cpc->nextInst = p; + cip->cpc = p; + } +} + CELL * Yap_emit_extra_size (compiler_vm_op o, CELL r1, int size, struct intermediates *cip) { @@ -415,14 +478,51 @@ write_address(CELL address) sprintf(buf,"%p",(void *)address); #endif p[31] = '\0'; /* so that I don't have to worry */ - Yap_DebugErrorPutc('0'); - Yap_DebugErrorPutc('x'); + //Yap_DebugErrorPutc('0'); + //Yap_DebugErrorPutc('x'); while (*p != '\0') { Yap_DebugErrorPutc(*p++); } } } +static void +write_special_label(special_label_op arg, special_label_id rn, UInt lab) +{ + switch (arg) { + case SPECIAL_LABEL_INIT: + Yap_DebugErrorPuts("init,"); + switch (rn) { + case SPECIAL_LABEL_EXCEPTION: + Yap_DebugErrorPuts("exception,"); + break; + case SPECIAL_LABEL_SUCCESS: + Yap_DebugErrorPuts("success,"); + break; + case SPECIAL_LABEL_FAILURE: + Yap_DebugErrorPuts("fail,"); + break; + } + write_address(lab); + case SPECIAL_LABEL_SET: + Yap_DebugErrorPuts("set,"); + break; + case SPECIAL_LABEL_CLEAR: + Yap_DebugErrorPuts("clear,"); + switch (rn) { + case SPECIAL_LABEL_EXCEPTION: + Yap_DebugErrorPuts("exception"); + break; + case SPECIAL_LABEL_SUCCESS: + Yap_DebugErrorPuts("success"); + break; + case SPECIAL_LABEL_FAILURE: + Yap_DebugErrorPuts("fail"); + break; + } + } +} + static void write_functor(Functor f) { @@ -445,14 +545,38 @@ write_functor(Functor f) } } -static void -ShowOp (const char *f, struct PSEUDO *cpc) +char *opDesc[] = { mklist(f_arr) }; + +static void send_pred(PredEntry *p) { + Functor f = p->FunctorOfPred; + UInt arity = p->ArityOfPE; + Term mod = TermProlog; + + if (p->ModuleOfPred) mod = p->ModuleOfPred; + Yap_DebugPlWrite (mod); + Yap_DebugErrorPutc (':'); + if (arity == 0) + Yap_DebugPlWrite (MkAtomTerm ((Atom)f)); + else + Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f))); + Yap_DebugErrorPutc ('/'); + Yap_DebugPlWrite (MkIntTerm (arity)); +} + + +static void +ShowOp (compiler_vm_op ic, const char *f, struct PSEUDO *cpc) +{ + CACHE_REGS char ch; Int arg = cpc->rnd1; Int rn = cpc->rnd2; CELL *cptr = cpc->arnds; + if (ic != label_op && ic != label_ctl_op && ic != name_op) { + Yap_DebugErrorPutc ('\t'); + } while ((ch = *f++) != 0) { if (ch == '%') @@ -466,6 +590,19 @@ ShowOp (const char *f, struct PSEUDO *cpc) Yap_DebugPlWrite(MkIntTerm(arg)); break; #endif + case '2': + { + Ventry *v = (Ventry *) cpc->rnd3; + Yap_DebugErrorPutc (v->KindOfVE == PermVar ? 'Y' : 'X'); + Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs)); + Yap_DebugErrorPutc (','); + Yap_DebugErrorPutc ('A'); + Yap_DebugPlWrite (MkIntegerTerm (cpc->rnd4)); + Yap_DebugErrorPutc (','); + send_pred( RepPredProp((Prop)(cpc->rnd5)) ); + } + break; + case 'a': case 'n': case 'S': @@ -474,7 +611,6 @@ ShowOp (const char *f, struct PSEUDO *cpc) case 'b': /* write a variable bitmap for a call */ { - CACHE_REGS int max = arg/(8*sizeof(CELL)), i; CELL *ptr = cptr; for (i = 0; i <= max; i++) { @@ -485,6 +621,9 @@ ShowOp (const char *f, struct PSEUDO *cpc) case 'l': write_address (arg); break; + case 'L': + write_special_label (arg, rn, cpc->rnd3); + break; case 'B': { char s[32]; @@ -494,10 +633,7 @@ ShowOp (const char *f, struct PSEUDO *cpc) } break; case 'd': - { - CACHE_REGS - Yap_DebugPlWrite (MkIntegerTerm (arg)); - } + Yap_DebugPlWrite (MkIntegerTerm (arg)); break; case 'z': Yap_DebugPlWrite (MkIntTerm (cpc->rnd3)); @@ -520,50 +656,17 @@ ShowOp (const char *f, struct PSEUDO *cpc) Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs)); } break; - case 'm': - Yap_DebugPlWrite (MkAtomTerm ((Atom) arg)); - Yap_DebugErrorPutc ('/'); - Yap_DebugPlWrite (MkIntTerm (rn)); - break; + case 'm': + Yap_DebugPlWrite (MkAtomTerm ((Atom) arg)); + Yap_DebugErrorPutc ('/'); + Yap_DebugPlWrite (MkIntTerm (rn)); + break; case 'p': - { - PredEntry *p = RepPredProp ((Prop) arg); - Functor f = p->FunctorOfPred; - UInt arity = p->ArityOfPE; - Term mod; - - if (p->ModuleOfPred) - mod = p->ModuleOfPred; - else - mod = TermProlog; - Yap_DebugPlWrite (mod); - Yap_DebugErrorPutc (':'); - if (arity == 0) - Yap_DebugPlWrite (MkAtomTerm ((Atom)f)); - else - Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f))); - Yap_DebugErrorPutc ('/'); - Yap_DebugPlWrite (MkIntTerm (arity)); - } - break; - case 'P': - { - PredEntry *p = RepPredProp((Prop) rn); - Functor f = p->FunctorOfPred; - UInt arity = p->ArityOfPE; - Term mod = TermProlog; - - if (p->ModuleOfPred) mod = p->ModuleOfPred; - Yap_DebugPlWrite (mod); - Yap_DebugErrorPutc (':'); - if (arity == 0) - Yap_DebugPlWrite (MkAtomTerm ((Atom)f)); - else - Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f))); - Yap_DebugErrorPutc ('/'); - Yap_DebugPlWrite (MkIntTerm (arity)); - } - break; + send_pred( RepPredProp((Prop)(arg) )); + break; + case 'P': + send_pred( RepPredProp((Prop)(rn) )); + break; case 'f': write_functor((Functor)arg); break; @@ -667,342 +770,6 @@ ShowOp (const char *f, struct PSEUDO *cpc) Yap_DebugErrorPutc ('\n'); } -static const char * -getFormat(compiler_vm_op ic) { - switch( ic ) { - case nop_op: - return "nop"; - case get_var_op: - return "get_var\t\t%v,%r"; - case put_var_op: - return "put_var\t\t%v,%r"; - case get_val_op: - return "get_val\t\t%v,%r"; - case put_val_op: - return "put_val\t\t%v,%r"; - case get_atom_op: - return "get_atom\t%a,%r"; - case put_atom_op: - return "put_atom\t%a,%r"; - case get_num_op: - return "get_num\t\t%n,%r"; - case put_num_op: - return "put_num\t\t%n,%r"; - case get_float_op: - return "get_float\t\t%w,%r"; - case put_float_op: - return "put_float\t\t%w,%r"; - case get_string_op: - return "get_string\t\t%w,%S"; - case put_string_op: - return "put_string\t\t%w,%S"; - case get_dbterm_op: - return "get_dbterm\t%w,%r"; - case put_dbterm_op: - return "put_dbterm\t%w,%r"; - case get_longint_op: - return "get_longint\t\t%w,%r"; - case put_longint_op: - return "put_longint\t\t%w,%r"; - case get_bigint_op: - return "get_bigint\t\t%l,%r"; - case put_bigint_op: - return "put_bigint\t\t%l,%r"; - case get_list_op: - return "get_list\t%r"; - case put_list_op: - return "put_list\t%r"; - case get_struct_op: - return "get_struct\t%f,%r"; - case put_struct_op: - return "put_struct\t%f,%r"; - case put_unsafe_op: - return "put_unsafe\t%v,%r"; - case unify_var_op: - return "unify_var\t%v"; - case write_var_op: - return "write_var\t%v"; - case unify_val_op: - return "unify_val\t%v"; - case write_val_op: - return "write_val\t%v"; - case unify_atom_op: - return "unify_atom\t%a"; - case write_atom_op: - return "write_atom\t%a"; - case unify_num_op: - return "unify_num\t%n"; - case write_num_op: - return "write_num\t%n"; - case unify_float_op: - return "unify_float\t%w"; - case write_float_op: - return "write_float\t%w"; - case unify_string_op: - return "unify_string\t%S"; - case write_string_op: - return "write_string\t%S"; - case unify_dbterm_op: - return "unify_dbterm\t%w"; - case write_dbterm_op: - return "write_dbterm\t%w"; - case unify_longint_op: - return "unify_longint\t%w"; - case write_longint_op: - return "write_longint\t%w"; - case unify_bigint_op: - return "unify_bigint\t%l"; - case write_bigint_op: - return "write_bigint\t%l"; - case unify_list_op: - return "unify_list"; - case write_list_op: - return "write_list"; - case unify_struct_op: - return "unify_struct\t%f"; - case write_struct_op: - return "write_struct\t%f"; - case write_unsafe_op: - return "write_unsafe\t%v"; - case unify_local_op: - return "unify_local\t%v"; - case write_local_op: - return "write local\t%v"; - case unify_last_list_op: - return "unify_last_list"; - case write_last_list_op: - return "write_last_list"; - case unify_last_struct_op: - return "unify_last_struct\t%f"; - case write_last_struct_op: - return "write_last_struct\t%f"; - case unify_last_var_op: - return "unify_last_var\t%v"; - case unify_last_val_op: - return "unify_last_val\t%v"; - case unify_last_local_op: - return "unify_last_local\t%v"; - case unify_last_atom_op: - return "unify_last_atom\t%a"; - case unify_last_num_op: - return "unify_last_num\t%n"; - case unify_last_float_op: - return "unify_last_float\t%w"; - case unify_last_string_op: - return "unify_last_string\t%S"; - case unify_last_dbterm_op: - return "unify_last_dbterm\t%w"; - case unify_last_longint_op: - return "unify_last_longint\t%w"; - case unify_last_bigint_op: - return "unify_last_bigint\t%l"; - case ensure_space_op: - return "ensure_space"; - case native_op: - return "native_code"; - case f_var_op: - return "function_to_var\t%v,%B"; - case f_val_op: - return "function_to_val\t%v,%B"; - case f_0_op: - return "function_to_0\t%B"; - case align_float_op: - return "align_float"; - case fail_op: - return "fail"; - case cut_op: - return "cut"; - case cutexit_op: - return "cutexit"; - case allocate_op: - return "allocate"; - case deallocate_op: - return "deallocate"; - case tryme_op: - return "try_me_else\t\t%l\t%x"; - case jump_op: - return "jump\t\t%l"; - case jumpi_op: - return "jump_in_indexing\t\t%i"; - case procceed_op: - return "proceed"; - case call_op: - return "call\t\t%p,%d,%z"; - case execute_op: - return "execute\t\t%p"; - case safe_call_op: - return "sys\t\t%p"; - case label_op: - return "%l:"; - case name_op: - return "name\t\t%m,%d"; - case pop_op: - return "pop\t\t%l"; - case retryme_op: - return "retry_me_else\t\t%l\t%x"; - case trustme_op: - return "trust_me_else_fail\t%x"; - case either_op: - return "either_me\t\t%l,%d,%z"; - case orelse_op: - return "or_else\t\t%l,%z"; - case orlast_op: - return "or_last"; - case push_or_op: - return "push_or"; - case pop_or_op: - return "pop_or"; - case pushpop_or_op: - return "pushpop_or"; - case save_b_op: - return "save_by\t\t%v"; - case commit_b_op: - return "commit_by\t\t%v"; - case patch_b_op: - return "patch_by\t\t%v"; - case try_op: - return "try\t\t%g\t%x"; - case retry_op: - return "retry\t\t%g\t%x"; - case trust_op: - return "trust\t\t%g\t%x"; - case try_in_op: - return "try_in\t\t%g\t%x"; - case jump_v_op: - return "jump_if_var\t\t%g"; - case jump_nv_op: - return "jump_if_nonvar\t\t%g"; - case cache_arg_op: - return "cache_arg\t%r"; - case cache_sub_arg_op: - return "cache_sub_arg\t%d"; - case user_switch_op: - return "user_switch"; - case switch_on_type_op: - return "switch_on_type\t%h\t%h\t%h\t%h"; - case switch_c_op: - return "switch_on_constant\t%i\n%c"; - case if_c_op: - return "if_constant\t%i\n%c"; - case switch_f_op: - return "switch_on_functor\t%i\n%e"; - case if_f_op: - return "if_functor\t%i\n%e"; - case if_not_op: - return "if_not_then\t%i\t%h\t%h\t%h"; - case index_dbref_op: - return "index_on_dbref"; - case index_blob_op: - return "index_on_blob"; - case index_long_op: - return "index_on_blob"; - case index_string_op: - return "index_on_string"; - case if_nonvar_op: - return "check_var\t %r"; - case save_pair_op: - return "save_pair\t%v"; - case save_appl_op: - return "save_appl\t%v"; - case mark_initialised_pvars_op: - return "pvar_bitmap\t%l,%b"; - case mark_live_regs_op: - return "pvar_live_regs\t%l,%b"; - case fetch_args_vv_op: - return "fetch_reg1_reg2\t%N,%N"; - case fetch_args_cv_op: - return "fetch_constant_reg\t%l,%N"; - case fetch_args_vc_op: - return "fetch_reg_constant\t%l,%N"; - case fetch_args_iv_op: - return "fetch_integer_reg\t%d,%N"; - case fetch_args_vi_op: - return "fetch_reg_integer\t%d,%N"; - case enter_profiling_op: - return "enter_profiling\t\t%g"; - case retry_profiled_op: - return "retry_profiled\t\t%g"; - case count_call_op: - return "count_call_op\t\t%g"; - case count_retry_op: - return "count_retry_op\t\t%g"; - case restore_tmps_op: - return "restore_temps\t\t%l"; - case restore_tmps_and_skip_op: - return "restore_temps_and_skip\t\t%l"; - case enter_lu_op: - return "enter_lu"; - case empty_call_op: - return "empty_call\t\t%l,%d"; -#ifdef YAPOR - case sync_op: - return "sync"; -#endif /* YAPOR */ -#ifdef TABLING - case table_new_answer_op: - return "table_new_answer"; - case table_try_single_op: - return "table_try_single\t%g\t%x"; -#endif /* TABLING */ -#ifdef TABLING_INNER_CUTS - case "clause_with_cut": - return clause_with_cut_op; -#endif /* TABLING_INNER_CUTS */ -#ifdef BEAM - "run_op %1,%4", - "body_op %1", - "endgoal_op", - "try_me_op %1,%4", - "retry_me_op %1,%4", - "trust_me_op %1,%4", - "only_1_clause_op %1,%4", - "create_first_box_op %1,%4", - "create_box_op %1,%4", - "create_last_box_op %1,%4", - "remove_box_op %1,%4", - "remove_last_box_op %1,%4", - "prepare_tries", - "std_base_op %1,%4", - "direct_safe_call", - "skip_while_var_op", - "wait_while_var_op", - "force_wait_op", - "write_op", - "is_op", - "equal_op", - "exit", -#endif - case fetch_args_for_bccall_op: - return "fetch_args_for_bccall\t%v"; - case bccall_op: - return "binary_cfunc\t\t%v,%P"; - case blob_op: - return "blob\t%O"; - case string_op: - return "string\t%O"; - case label_ctl_op: - return "label_control\t"; -#ifdef SFUNC - , - "get_s_f_op\t%f,%r", - "put_s_f_op\t%f,%r", - "unify_s_f_op\t%f", - "write_s_f_op\t%f", - "unify_s_var\t%v,%r", - "write_s_var\t%v,%r", - "unify_s_val\t%v,%r", - "write_s_val\t%v,%r", - "unify_s_a\t%a,%r", - "write_s_a\t%a,%r", - "get_s_end", - "put_s_end", - "unify_s_end", - "write_s_end" -#endif - } - return NULL; -} - void Yap_ShowCode (struct intermediates *cint) { @@ -1015,8 +782,8 @@ Yap_ShowCode (struct intermediates *cint) while (cpc) { compiler_vm_op ic = cpc->op; if (ic != nop_op) { - } - ShowOp (getFormat(ic), cpc); + ShowOp (ic, opDesc[ic], cpc); + } cpc = cpc->nextInst; } Yap_DebugErrorPutc ('\n'); diff --git a/H/compile.h b/H/compile.h index 60863826b..9c462202e 100644 --- a/H/compile.h +++ b/H/compile.h @@ -18,197 +18,222 @@ /* consult stack management */ /* virtual machine instruction op-codes */ -typedef enum compiler_op { - nop_op, - get_var_op, - put_var_op, - get_val_op, - put_val_op, - get_atom_op, - put_atom_op, - get_num_op, - put_num_op, - get_float_op, - put_float_op, - get_dbterm_op, - put_dbterm_op, - get_longint_op, - put_longint_op, - get_string_op, - put_string_op, - get_bigint_op, - put_bigint_op, - get_list_op, - put_list_op, - get_struct_op, - put_struct_op, - put_unsafe_op, - unify_var_op, - write_var_op, - unify_val_op, - write_val_op, - unify_atom_op, - write_atom_op, - unify_num_op, - write_num_op, - unify_float_op, - write_float_op, - unify_dbterm_op, - write_dbterm_op, - unify_longint_op, - write_longint_op, - unify_string_op, - write_string_op, - unify_bigint_op, - write_bigint_op, - unify_list_op, - write_list_op, - unify_struct_op, - write_struct_op, - write_unsafe_op, - unify_local_op, - write_local_op, - unify_last_list_op, - write_last_list_op, - unify_last_struct_op, - write_last_struct_op, - unify_last_var_op, - unify_last_val_op, - unify_last_local_op, - unify_last_atom_op, - unify_last_num_op, - unify_last_float_op, - unify_last_dbterm_op, - unify_last_longint_op, - unify_last_string_op, - unify_last_bigint_op, - ensure_space_op, - native_op, - f_var_op, - f_val_op, - f_0_op, - align_float_op, - fail_op, - cut_op, - cutexit_op, - allocate_op, - deallocate_op, - tryme_op, - jump_op, - jumpi_op, - procceed_op, - call_op, - execute_op, - safe_call_op, - label_op, - name_op, - pop_op, - retryme_op, - trustme_op, - either_op, - orelse_op, - orlast_op, - push_or_op, - pushpop_or_op, - pop_or_op, - save_b_op, - commit_b_op, - patch_b_op, - try_op, - retry_op, - trust_op, - try_in_op, - jump_v_op, - jump_nv_op, - cache_arg_op, - cache_sub_arg_op, - user_switch_op, - switch_on_type_op, - switch_c_op, - if_c_op, - switch_f_op, - if_f_op, - if_not_op, - index_dbref_op, - index_blob_op, - index_string_op, - index_long_op, - if_nonvar_op, - save_pair_op, - save_appl_op, - mark_initialised_pvars_op, - mark_live_regs_op, - fetch_args_vv_op, - fetch_args_cv_op, - fetch_args_vc_op, - fetch_args_iv_op, - fetch_args_vi_op, - enter_profiling_op, - retry_profiled_op, - count_call_op, - count_retry_op, - restore_tmps_op, - restore_tmps_and_skip_op, - enter_lu_op, - empty_call_op, +#define mklist0(f) \ + f( nop_op, "nop") \ + f( get_var_op, "get_var\t\t%v,%r") \ + f( put_var_op, "put_var\t\t%v,%r") \ + f( get_val_op, "get_val\t\t%v,%r") \ + f( put_val_op, "put_val\t\t%v,%r") \ + f( get_atom_op, "get_atom\t%a,%r") \ + f( put_atom_op, "put_atom\t%a,%r") \ + f( get_num_op, "get_num\t\t%n,%r") \ + f( put_num_op, "put_num\t\t%n,%r") \ + f( get_float_op,"get_float\t\t%w,%r" ) \ + f( put_float_op, "put_float\t\t%w,%r") \ + f( get_dbterm_op, "get_dbterm\t%w,%r") \ + f( put_dbterm_op, "put_dbterm\t%w,%r") \ + f( get_longint_op, "get_longint\t\t%w,%r") \ + f( put_longint_op, "put_longint\t\t%w,%r") \ + f( get_string_op, "get_string\t\t%w,%S") \ + f( put_string_op, "put_string\t\t%w,%S") \ + f( get_bigint_op, "get_bigint\t\t%l,%r") \ + f( put_bigint_op, "put_bigint\t\t%l,%r") \ + f( get_list_op, "get_list\t%r") \ + f( put_list_op, "put_list\t%r") \ + f( get_struct_op, "get_struct\t%f,%r") \ + f( put_struct_op, "put_struct\t%f,%r") \ + f( put_unsafe_op, "put_unsafe\t%v,%r") \ + f( unify_var_op, "unify_var\t%v") \ + f( write_var_op, "write_var\t%v") \ + f( unify_val_op, "unify_val\t%v") \ + f( write_val_op, "write_val\t%v") \ + f( unify_atom_op, "unify_atom\t%a") \ + f( write_atom_op, "write_atom\t%a") \ + f( unify_num_op, "unify_num\t%n") \ + f( write_num_op, "write_num\t%n") \ + f( unify_float_op, "unify_float\t%w") \ + f( write_float_op, "write_float\t%w") \ + f( unify_dbterm_op, "unify_dbterm\t%w") \ + f( write_dbterm_op, "write_dbterm\t%w") \ + f( unify_longint_op, "unify_longint\t%w") \ + f( write_longint_op, "write_longint\t%w") \ + f( unify_string_op, "unify_string\t%S") \ + f( write_string_op, "write_string\t%S") \ + f( unify_bigint_op, "unify_bigint\t%l") \ + f( write_bigint_op, "write_bigint\t%l") \ + f( unify_list_op, "unify_list") \ + f( write_list_op, "write_list") \ + f( unify_struct_op, "unify_struct\t%f") \ + f( write_struct_op, "write_struct\t%f") \ + f( write_unsafe_op, "write_unsafe\t%v") \ + f( unify_local_op, "unify_local\t%v") \ + f( write_local_op, "write local\t%v") \ + f( unify_last_list_op, "unify_last_list") \ + f( write_last_list_op, "write_last_list") \ + f( unify_last_struct_op, "unify_last_struct\t%f") \ + f( write_last_struct_op, "write_last_struct\t%f") \ + f( unify_last_var_op, "unify_last_var\t%v") \ + f( unify_last_val_op, "unify_last_val\t%v") \ + f( unify_last_local_op, "unify_last_local\t%v") \ + f( unify_last_atom_op, "unify_last_atom\t%a") \ + f( unify_last_num_op, "unify_last_num\t%n") \ + f( unify_last_float_op, "unify_last_float\t%w") \ + f( unify_last_dbterm_op, "unify_last_dbterm\t%w") \ + f( unify_last_longint_op, "unify_last_longint\t%w") \ + f( unify_last_string_op, "unify_last_string\t%S") \ + f( unify_last_bigint_op, "unify_last_bigint\t%l") \ + f( ensure_space_op, "ensure_space") \ + f( native_op, "native_code") \ + f( f_var_op, "function_to_var\t%v,%B") \ + f( f_val_op, "function_to_val\t%v,%B") \ + f( f_0_op, "function_to_0\t%B") \ + f( align_float_op, "align_float") \ + f( fail_op, "fail") \ + f( cut_op, "cut") \ + f( cutexit_op, "cutexit") \ + f( allocate_op, "allocate") \ + f( deallocate_op, "deallocate") \ + f( tryme_op, "try_me_else\t\t%l\t%x") \ + f( jump_op, "jump\t\t%l") \ + f( jumpi_op, "jump_in_indexing\t\t%i") \ + f( procceed_op, "proceed") \ + f( call_op, "call\t\t%p,%d,%z") \ + f( execute_op, "execute\t\t%p") \ + f( safe_call_op, "sys\t\t%p") \ + f( label_op, "%l:") \ + f( name_op, "name\t\t%m,%d") \ + f( pop_op, "pop\t\t%l") \ + f( retryme_op, "retry_me_else\t\t%l\t%x") \ + f( trustme_op, "trust_me_else_fail\t%x") \ + f( either_op, "either_me\t\t%l,%d,%z") \ + f( orelse_op, "or_else\t\t%l,%z") \ + f( orlast_op, "or_last") \ + f( push_or_op, "push_or") \ + f( pushpop_or_op, "pushpop_or") \ + f( pop_or_op, "pop_or") \ + f( save_b_op, "save_by\t\t%v") \ + f( commit_b_op, "commit_by\t\t%v") \ + f( patch_b_op, "patch_by\t\t%v") \ + f( try_op, "try\t\t%g\t%x") \ + f( retry_op, "retry\t\t%g\t%x") \ + f( trust_op, "trust\t\t%g\t%x") \ + f( try_in_op, "try_in\t\t%g\t%x") \ + f( jump_v_op, "jump_if_var\t\t%g") \ + f( jump_nv_op, "jump_if_nonvar\t\t%g") \ + f( cache_arg_op, "cache_arg\t%r") \ + f( cache_sub_arg_op, "cache_sub_arg\t%d") \ + f( user_switch_op, "user_switch") \ + f( switch_on_type_op, "switch_on_type\t%h\t%h\t%h\t%h") \ + f( switch_c_op, "switch_on_constant\t%i\n%c") \ + f( if_c_op, "if_constant\t%i\n%c") \ + f( switch_f_op, "switch_on_functor\t%i\n%e") \ + f( if_f_op, "if_functor\t%i\n%e") \ + f( if_not_op, "if_not_then\t%i\t%h\t%h\t%h") \ + f( index_dbref_op, "index_on_dbref") \ + f( index_blob_op, "index_on_blob") \ + f( index_string_op, "index_on_string") \ + f( index_long_op, "index_on_blob") \ + f( if_nonvar_op, "check_var\t %r") \ + f( save_pair_op, "save_pair\t%v") \ + f( save_appl_op, "save_appl\t%v") \ + f( mark_initialised_pvars_op, "pvar_bitmap\t%l,%b") \ + f( mark_live_regs_op, "pvar_live_regs\t%l,%b") \ + f( fetch_args_vv_op, "fetch_reg1_reg2\t%N,%N") \ + f( fetch_args_cv_op, "fetch_constant_reg\t%l,%N") \ + f( fetch_args_vc_op, "fetch_reg_constant\t%l,%N") \ + f( fetch_args_iv_op, "fetch_integer_reg\t%d,%N") \ + f( fetch_args_vi_op, "fetch_reg_integer\t%d,%N") \ + f( enter_profiling_op, "enter_profiling\t\t%g") \ + f( retry_profiled_op, "retry_profiled\t\t%g") \ + f( count_call_op, "count_call_op\t\t%g") \ + f( count_retry_op, "count_retry_op\t\t%g") \ + f( restore_tmps_op, "restore_temps\t\t%l") \ + f( restore_tmps_and_skip_op, "restore_temps_and_skip\t\t%l") \ + f( enter_lu_op, "enter_lu") \ + f( empty_call_op, "empty_call\t\t%l,%d") \ + f( bccall_op, "binary_cfunc\t\t%v,%r,%2") \ + f( blob_op, "blob\t%O") \ + f( string_op, "string\t%O") \ + f( label_ctl_op, "label_control\t") #ifdef YAPOR - sync_op, +#define mklist1(f) \ + mklist0(f) \ + f( sync_op, "sync") +#else +#define mklist1(f) mklist0(f) #endif /* YAPOR */ #ifdef TABLING - table_new_answer_op, - table_try_single_op, +#define mklist2(f) \ + mklist1(f) \ + f( table_new_answer_op, "table_new_answer") \ + f( table_try_single_op, "table_try_single\t%g\t%x") +#else +#define mklist2(f) mklist1(f) #endif /* TABLING */ #ifdef TABLING_INNER_CUTS - clause_with_cut_op, +#define mklist3(f) \ + mklist2(f) \ + f( clause_with_cut_op, "clause_with_cut") +#else +#define mklist3(f) mklist2(f) #endif /* TABLING_INNER_CUTS */ #ifdef BEAM - run_op, - body_op, - endgoal_op, - try_me_op, - retry_me_op, - trust_me_op, - only_1_clause_op, - create_first_box_op, - create_box_op, - create_last_box_op, - remove_box_op, - remove_last_box_op, - prepare_tries, - std_base_op, - direct_safe_call_op, - commit_op, - skip_while_var_op, - wait_while_var_op, - force_wait_op, - write_op, - equal_op, - exit_op, +#define mklist4(f) \ + mklist3(f) \ + f( run_op, "run_op %1,%4") \ + f( body_op, "body_op %1") \ + f( endgoal_op, "endgoal_op") \ + f( try_me_op, "try_me_op %1,%4") \ + f( retry_me_op, "retry_me_op %1,%4") \ + f( trust_me_op, "trust_me_op %1,%4") \ + f( only_1_clause_op, "only_1_clause_op %1,%4") \ + f( create_first_box_op, "create_first_box_op %1,%4") \ + f( create_box_op, "create_box_op %1,%4") \ + f( create_last_box_op, "create_last_box_op %1,%4") \ + f( remove_box_op, "remove_box_op %1,%4") \ + f( remove_last_box_op, "remove_last_box_op %1,%4" ) \ + f( prepare_tries, "prepare_tries") \ + f( std_base_op, "std_base_op %1,%4") \ + f( direct_safe_call_op, "direct_safe_call") \ + f( commit_op, ) \ + f( skip_while_var_op, "skip_while_var_op") \ + f( wait_while_var_op, "wait_while_var_op") \ + f( force_wait_op, "force_wait_op") \ + f( is_op, "is_op") \ + f( write_op, "write_op") \ + f( equal_op, "equal_op") \ + f( exit_op, "exit") +#else +#define mklist4(f) mklist3(f) #endif - fetch_args_for_bccall_op, - bccall_op, - blob_op, - string_op, - label_ctl_op #ifdef SFUNC - , - get_s_f_op, - put_s_f_op, - unify_s_f_op, - write_s_f_op, - unify_s_var_op, - write_s_var_op, - unify_s_val_op, - write_s_val_op, - unify_s_a_op, - write_s_a_op, - get_s_end_op, - put_s_end_op, - unify_s_end_op, - write_s_end_op, +#define mklist(f) \ + mklist4(f) \ + f( get_s_f_op, "get_s_f_op\t%f,%r") \ + f( put_s_f_op, "put_s_f_op\t%f,%r") \ + f( unify_s_f_op, "unify_s_f_op\t%f") \ + f( write_s_f_op, "write_s_f_op\t%f") \ + f( unify_s_var_op, "unify_s_var\t%v,%r") \ + f( write_s_var_op, "write_s_var\t%v,%r") \ + f( unify_s_val_op, "unify_s_val\t%v,%r") \ + f( write_s_val_op, "write_s_val\t%v,%r") \ + f( unify_s_a_op, "unify_s_a\t%a,%r") \ + f( write_s_a_op, "write_s_a\t%a,%r") \ + f( get_s_end_op, "get_s_end") \ + f( put_s_end_op, "put_s_end") \ + f( unify_s_end_op, "unify_s_end") \ + f( write_s_end_op, "write_s_end") +#else +#define mklist(f) mklist4(f) #endif -} compiler_vm_op; +#define f_enum(x, y) x, +#define f_arr(x, y) y, + +enum compiler_op { mklist(f_enum) }; + +typedef enum compiler_op compiler_vm_op; + typedef struct PSEUDO { struct PSEUDO *nextInst; @@ -228,6 +253,10 @@ typedef struct PSEUDO { #define rnd2 ops.oprnd2 #define rnd3 ops.opseqt[1] #define rnd4 ops.opseqt[2] +#define rnd5 ops.opseqt[3] +#define rnd6 ops.opseqt[4] +#define rnd7 ops.opseqt[5] +#define rnd8 ops.opseqt[6] typedef struct VENTRY { CELL SelfOfVE; @@ -325,8 +354,8 @@ typedef enum special_label_op_enum { #define save_appl_flag 0x10002 #define save_pair_flag 0x10004 #define f_flag 0x10008 -#define bt1_flag 0x10010 -#define bt2_flag 0x10020 +#define bt_flag 0x10010 +#define bt2_flag 0x10020 // unused #define patch_b_flag 0x10040 #define init_v_flag 0x10080 @@ -340,6 +369,9 @@ yamop *Yap_assemble(int,Term,struct pred_entry *,int, struct intermediates *, U void Yap_emit(compiler_vm_op,Int,CELL, struct intermediates *); void Yap_emit_3ops(compiler_vm_op,CELL,CELL,CELL, struct intermediates *); void Yap_emit_4ops(compiler_vm_op,CELL,CELL,CELL,CELL, struct intermediates *); +void Yap_emit_5ops(compiler_vm_op,CELL,CELL,CELL,CELL,CELL, struct intermediates *); +void Yap_emit_6ops(compiler_vm_op,CELL,CELL,CELL,CELL,CELL,CELL, struct intermediates *); +void Yap_emit_7ops(compiler_vm_op,CELL,CELL,CELL,CELL,CELL,CELL,CELL, struct intermediates *); CELL *Yap_emit_extra_size(compiler_vm_op,CELL,int, struct intermediates *); char *Yap_AllocCMem(UInt, struct intermediates *); void Yap_ReleaseCMem(struct intermediates *); From 81440607f1874aa2888d8ca7e56f50e42025dd61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:17:26 +0100 Subject: [PATCH 02/25] support outputting strings for debugging. --- C/iopreds.c | 15 +++++++++++++++ H/Yapproto.h | 1 + 2 files changed, 16 insertions(+) diff --git a/C/iopreds.c b/C/iopreds.c index 30b0c12da..cb6561aa2 100644 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -199,6 +199,14 @@ Yap_DebugPutc(int sno, wchar_t ch) return (Sputc(ch, GLOBAL_stderr)); } +static int +Yap_DebugPuts(int sno, const char * s) +{ + if (GLOBAL_Option['l' - 96]) + (void) fputs(s, GLOBAL_logfile); + return (Sfputs(s, GLOBAL_stderr)); +} + void Yap_DebugPlWrite(Term t) { @@ -212,6 +220,13 @@ Yap_DebugErrorPutc(int c) Yap_DebugPutc (LOCAL_c_error_stream, c); } +void +Yap_DebugErrorPuts(const char *s) +{ + CACHE_REGS + Yap_DebugPuts (LOCAL_c_error_stream, s); +} + #endif diff --git a/H/Yapproto.h b/H/Yapproto.h index 7ec515f9e..83acf11bb 100755 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -283,6 +283,7 @@ void *Yap_GetOutputStream(Atom at); #ifdef DEBUG extern void Yap_DebugPlWrite (Term t); extern void Yap_DebugErrorPutc (int n); +extern void Yap_DebugErrorPuts (const char *s); #endif void Yap_PlWriteToStream(Term, int, int); /* depth_lim.c */ From e22b2febf4e20ab6e92371b74364063d103f0adf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:19:53 +0100 Subject: [PATCH 03/25] update too change in library(lineutils). --- misc/HEAPFIELDS | 2 +- misc/buildheap | 26 +++++++++++++------------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/misc/HEAPFIELDS b/misc/HEAPFIELDS index d2814a4a1..81ea68302 100644 --- a/misc/HEAPFIELDS +++ b/misc/HEAPFIELDS @@ -325,7 +325,7 @@ struct record_list *yap_records Yap_Records =NULL RestoreYapRecords() /* SWI atoms and functors */ Atom *swi_atoms SWI_Atoms InitSWIAtoms() RestoreSWIAtoms() -Functor swi_functors[N_SWI_FUNCTORS] SWI_Functors void void +Functor *swi_functors SWI_Functors void void struct swi_reverse_hash swi_reverse_hash[N_SWI_HASH] SWI_ReverseHash void void diff --git a/misc/buildheap b/misc/buildheap index 85cfec22c..f67d70e29 100644 --- a/misc/buildheap +++ b/misc/buildheap @@ -1,6 +1,6 @@ :- use_module(library(lineutils), - [file_filter_with_init/5, + [file_filter_with_initialization/5, split/3, glue/3]). @@ -18,18 +18,18 @@ main :- warning(Warning), - file_filter_with_init('misc/HEAPFIELDS','H/hstruct.h',gen_struct,Warning,['hstruct.h','HEAPFIELDS']), - file_filter_with_init('misc/HEAPFIELDS','H/dhstruct.h',gen_dstruct,Warning,['dhstruct.h','HEAPFIELDS']), - file_filter_with_init('misc/HEAPFIELDS','H/rhstruct.h',gen_hstruct,Warning,['rhstruct.h','HEAPFIELDS']), - file_filter_with_init('misc/HEAPFIELDS','H/ihstruct.h',gen_init,Warning,['ihstruct.h','HEAPFIELDS']). - %file_filter_with_init('misc/GLOBALS','H/hglobals.h',gen_struct,Warning,['hglobals.h','GLOBALS']), - %file_filter_with_init('misc/GLOBALS','H/dglobals.h',gen_dstruct,Warning,['dglobals.h','GLOBALS']), - %file_filter_with_init('misc/GLOBALS','H/rglobals.h',gen_hstruct,Warning,['rglobals.h','GLOBALS']), - %file_filter_with_init('misc/GLOBALS','H/iglobals.h',gen_init,Warning,['iglobals.h','GLOBALS']), - %file_filter_with_init('misc/LOCALS','H/hlocals.h',gen_struct,Warning,['hlocals.h','LOCALS']), - %file_filter_with_init('misc/LOCALS','H/dlocals.h',gen_dstruct,Warning,['dlocals.h','LOCALS']), - %file_filter_with_init('misc/LOCALS','H/rlocals.h',gen_hstruct,Warning,['rlocals.h','LOCALS']), - %file_filter_with_init('misc/LOCALS','H/ilocals.h',gen_init,Warning,['ilocals.h','LOCALS']). + file_filter_with_initialization('misc/HEAPFIELDS','H/hstruct.h',gen_struct,Warning,['hstruct.h','HEAPFIELDS']), + file_filter_with_initialization('misc/HEAPFIELDS','H/dhstruct.h',gen_dstruct,Warning,['dhstruct.h','HEAPFIELDS']), + file_filter_with_initialization('misc/HEAPFIELDS','H/rhstruct.h',gen_hstruct,Warning,['rhstruct.h','HEAPFIELDS']), + file_filter_with_initialization('misc/HEAPFIELDS','H/ihstruct.h',gen_init,Warning,['ihstruct.h','HEAPFIELDS']). + %file_filter_with_initialization('misc/GLOBALS','H/hglobals.h',gen_struct,Warning,['hglobals.h','GLOBALS']), + %file_filter_with_initialization('misc/GLOBALS','H/dglobals.h',gen_dstruct,Warning,['dglobals.h','GLOBALS']), + %file_filter_with_initialization('misc/GLOBALS','H/rglobals.h',gen_hstruct,Warning,['rglobals.h','GLOBALS']), + %file_filter_with_initialization('misc/GLOBALS','H/iglobals.h',gen_init,Warning,['iglobals.h','GLOBALS']), + %file_filter_with_initialization('misc/LOCALS','H/hlocals.h',gen_struct,Warning,['hlocals.h','LOCALS']), + %file_filter_with_initialization('misc/LOCALS','H/dlocals.h',gen_dstruct,Warning,['dlocals.h','LOCALS']), + %file_filter_with_initialization('misc/LOCALS','H/rlocals.h',gen_hstruct,Warning,['rlocals.h','LOCALS']), + %file_filter_with_initialization('misc/LOCALS','H/ilocals.h',gen_init,Warning,['ilocals.h','LOCALS']). warning('~n /* This file, ~a, was generated automatically by \"yap -L misc/buildheap\"~n please do not update, update misc/~a instead */~n~n'). From 28c10dbefc0e383e6457c60c527857a5bd424ca8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:20:28 +0100 Subject: [PATCH 04/25] fix meta decl to agree with new name. --- library/lineutils.yap | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/lineutils.yap b/library/lineutils.yap index 86aeb4040..b24f07bb3 100644 --- a/library/lineutils.yap +++ b/library/lineutils.yap @@ -32,7 +32,7 @@ available by loading the :- meta_predicate filter(+,+,2), file_filter(+,+,2), - file_filter_with_init(+,+,2,+,:), + file_filter_with_initialization(+,+,2,+,:), process(+,1). :- use_module(library(lists), From 17617e8d20518b9626fc0dbaaf707b9476625c46 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:21:43 +0100 Subject: [PATCH 05/25] allow setting file ownership, and make sure preds created by aux programs have an owner file. --- C/cdmgr.c | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/C/cdmgr.c b/C/cdmgr.c index 03baa2623..ba6817ce9 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -1651,6 +1651,7 @@ source_pred(PredEntry *p, yamop *q) static void add_first_static(PredEntry *p, yamop *cp, int spy_flag) { + CACHE_REGS yamop *pt = cp; if (is_logupd(p)) { @@ -1701,12 +1702,17 @@ add_first_static(PredEntry *p, yamop *cp, int spy_flag) if (source_pred(p, cp)) { p->PredFlags |= SourcePredFlag; } + if (!(p->PredFlags & MultiFileFlag) && + p->src.OwnerFile == AtomNil) + p->src.OwnerFile = Yap_ConsultingFile( PASS_REGS1 ); + } /* p is already locked */ static void add_first_dynamic(PredEntry *p, yamop *cp, int spy_flag) { + CACHE_REGS yamop *ncp = ((DynamicClause *)NULL)->ClCode; DynamicClause *cl; if (p == PredGoalExpansion || p->FunctorOfPred == FunctorGoalExpansion2) { @@ -1797,6 +1803,10 @@ add_first_dynamic(PredEntry *p, yamop *cp, int spy_flag) ncp = NEXTOP(ncp,e); ncp->opc = Yap_opcode(_Ystop); ncp->y_u.l.l = cl->ClCode; + if (!(p->PredFlags & MultiFileFlag) && + p->src.OwnerFile == AtomNil) + p->src.OwnerFile = Yap_ConsultingFile( PASS_REGS1 ); + } /* p is already locked */ @@ -3264,6 +3274,28 @@ p_owner_file( USES_REGS1 ) return Yap_unify(ARG3, MkAtomTerm(owner)); } +static Int +p_set_owner_file( USES_REGS1 ) +{ /* '$owner_file'(+P,M,F) */ + PredEntry *pe; + + pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source"); + if (EndOfPAEntr(pe)) + return FALSE; + PELOCK(29,pe); + if (pe->ModuleOfPred == IDB_MODULE) { + UNLOCKPE(47,pe); + return FALSE; + } + if (pe->PredFlags & MultiFileFlag) { + UNLOCKPE(48,pe); + return FALSE; + } + pe->src.OwnerFile = AtomOfTerm(Deref(ARG3)); + UNLOCKPE(49,pe); + return TRUE; +} + static Int p_mk_d( USES_REGS1 ) { /* '$is_dynamic'(+P) */ @@ -6664,6 +6696,7 @@ Yap_InitCdMgr(void) Yap_InitCPred("$is_source", 2, p_is_source, TestPredFlag | SafePredFlag); Yap_InitCPred("$is_exo", 2, p_is_exo, TestPredFlag | SafePredFlag); Yap_InitCPred("$owner_file", 3, p_owner_file, SafePredFlag); + Yap_InitCPred("$set_owner_file", 3, p_set_owner_file, SafePredFlag); Yap_InitCPred("$mk_d", 2, p_mk_d, SafePredFlag); Yap_InitCPred("$sys_export", 2, p_sys_export, TestPredFlag | SafePredFlag); Yap_InitCPred("$pred_exists", 2, p_pred_exists, TestPredFlag | SafePredFlag); From 4fdd501bbbc3209cddd408f55c956dba843c179a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:24:12 +0100 Subject: [PATCH 06/25] qly is not a source file. --- pl/absf.yap | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/pl/absf.yap b/pl/absf.yap index c62e3946d..dccdcda57 100755 --- a/pl/absf.yap +++ b/pl/absf.yap @@ -30,7 +30,6 @@ remove_from_path/1], ['$full_filename'/3, '$system_library_directories'/2]). - :- use_system_module( '$_boot', ['$system_catch'/4]). :- use_system_module( '$_errors', ['$do_error'/2]). @@ -134,10 +133,8 @@ absolute_file_name(user,user) :- !. absolute_file_name(File0,File) :- '$absolute_file_name'(File0,[access(none),file_type(txt),file_errors(fail),solutions(first)],File,absolute_file_name(File0,File)). -'$full_filename'(F0,F,G) :- - '$absolute_file_name'(F0,[access(read),file_type(source),file_errors(fail),solutions(first),expand(true)],F,G). - - +'$full_filename'(F0, F, G) :- + '$absolute_file_name'(F0,[access(read),file_type(prolog),file_errors(fail),solutions(first),expand(true)],F,G). '$absolute_file_name'(File, _Opts, _TrueFileName, G) :- var(File), !, '$do_error'(instantiation_error, G). @@ -591,7 +588,6 @@ user:prolog_file_type(A, prolog) :- A \== prolog, A \==pl, A \== yap. -user:prolog_file_type(qly, prolog). user:prolog_file_type(qly, qly). user:prolog_file_type(A, executable) :- current_prolog_flag(shared_object_extension, A). From 2d5f8f136de8d6dc304fa796682083e4abcff350 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:25:11 +0100 Subject: [PATCH 07/25] SWI functors is now dynamic --- H/hstruct.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/H/hstruct.h b/H/hstruct.h index 672768fea..0872294f8 100755 --- a/H/hstruct.h +++ b/H/hstruct.h @@ -288,7 +288,7 @@ struct record_list *yap_records; Atom *swi_atoms; - Functor swi_functors[N_SWI_FUNCTORS]; + Functor *swi_functors; struct swi_reverse_hash swi_reverse_hash[N_SWI_HASH]; Int atom_translations; From 61ffaf5720ec89c2c3e843e72d8431ce1a59a25b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:26:50 +0100 Subject: [PATCH 08/25] avoid int --- os/SWI-Stream.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/os/SWI-Stream.h b/os/SWI-Stream.h index 7431f4525..81b8c70ad 100755 --- a/os/SWI-Stream.h +++ b/os/SWI-Stream.h @@ -112,8 +112,8 @@ typedef struct io_functions typedef struct io_position { int64_t byteno; /* byte-position in file */ int64_t charno; /* character position in file */ - int lineno; /* lineno in file */ - int linepos; /* position in line */ + long int lineno; /* lineno in file */ + long int linepos; /* position in line */ intptr_t reserved[2]; /* future extensions */ } IOPOS; From 3ab27ad588a208c974335aeac63eca082f3569bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:29:48 +0100 Subject: [PATCH 09/25] allow application to set source file, useful in saved states. --- os/pl-read.c | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/os/pl-read.c b/os/pl-read.c index fa16a776b..7698a788a 100644 --- a/os/pl-read.c +++ b/os/pl-read.c @@ -1570,6 +1570,24 @@ PRED_IMPL("term_to_atom", 2, term_to_atom, 0) { return atom_to_term(A2, A1, 0); } +static +PRED_IMPL("$set_source", 2, set_source, 0) +{ + GET_LD + atom_t at; + term_t a = PL_new_term_ref(); + + if (!PL_get_atom(A1, &at)) + return FALSE; + source_file_name = at; + if (!PL_get_arg(1, A2, a) || !PL_get_int64(a, &source_char_no) || + !PL_get_arg(2, A2, a) || !PL_get_long(a, &source_line_no) || + !PL_get_arg(3, A2, a) || !PL_get_long(a, &source_line_pos) || + !PL_get_arg(4, A2, a) || !PL_get_int64(a, &source_byte_no) ) { + return FALSE; + } + return TRUE; +} int PL_chars_to_term(const char *s, term_t t) @@ -1600,6 +1618,7 @@ PRED_DEF("read_term", 2, read_term, PL_FA_ISO) PRED_DEF("read_clause", 3, read_clause, 0) PRED_DEF("atom_to_term", 3, atom_to_term, 0) PRED_DEF("term_to_atom", 2, term_to_atom, 0) +PRED_DEF("$set_source", 2, set_source, 0) #ifdef O_QUASIQUOTATIONS PRED_DEF("$qq_open", 2, qq_open, 0) #endif From 74c136b986200686e2ed7092aaaea74d94a27e84 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:31:14 +0100 Subject: [PATCH 10/25] reorganise code to avoid duplicate goal_expansion. --- library/expand_macros.yap | 425 -------------------------------------- library/maplist.yap | 30 --- library/maputils.yap | 19 +- 3 files changed, 3 insertions(+), 471 deletions(-) diff --git a/library/expand_macros.yap b/library/expand_macros.yap index 43b5029ab..d181b7b82 100644 --- a/library/expand_macros.yap +++ b/library/expand_macros.yap @@ -5,429 +5,16 @@ %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -:- module(expand_macros, []). - :- use_module(library(lists), [append/3]). :- use_module(library(charsio), [format_to_chars/3, read_from_chars/2]). :- use_module(library(error), [must_be/2]). :- use_module(library(occurs), [sub_term/2]). -:- multifile user:goal_expansion/3. - :- dynamic number_of_expansions/1. number_of_expansions(0). -user:goal_expansion(checklist(Meta, List), Mod, Goal) :- - goal_expansion_allowed(checklist(Meta, List), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(checklist, 2, Proto, GoalName), - append(MetaVars, [List], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[]], Base), - append_args(HeadPrefix, [[In|Ins]], RecursionHead), - append_args(Pred, [In], Apply), - append_args(HeadPrefix, [Ins], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- Apply, RecursiveCall) - ], Module). -user:goal_expansion(maplist(Meta, List), Mod, Goal) :- - goal_expansion_allowed(maplist(Meta, List), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(maplist, 2, Proto, GoalName), - append(MetaVars, [List], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[]], Base), - append_args(HeadPrefix, [[In|Ins]], RecursionHead), - append_args(Pred, [In], Apply), - append_args(HeadPrefix, [Ins], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- Apply, RecursiveCall) - ], Module). - -user:goal_expansion(maplist(Meta, ListIn, ListOut), Mod, Goal) :- - goal_expansion_allowed(maplist(Meta, ListIn, ListOut), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(maplist, 3, Proto, GoalName), - append(MetaVars, [ListIn, ListOut], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], []], Base), - append_args(HeadPrefix, [[In|Ins], [Out|Outs]], RecursionHead), - append_args(Pred, [In, Out], Apply), - append_args(HeadPrefix, [Ins, Outs], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- Apply, RecursiveCall) - ], Module). - -user:goal_expansion(maplist(Meta, L1, L2, L3), Mod, Goal) :- - goal_expansion_allowed(maplist(Meta, L1, L2, L3), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(maplist, 4, Proto, GoalName), - append(MetaVars, [L1, L2, L3], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], [], []], Base), - append_args(HeadPrefix, [[A1|A1s], [A2|A2s], [A3|A3s]], RecursionHead), - append_args(Pred, [A1, A2, A3], Apply), - append_args(HeadPrefix, [A1s, A2s, A3s], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- Apply, RecursiveCall) - ], Module). - -user:goal_expansion(maplist(Meta, L1, L2, L3, L4), Mod, Goal) :- - goal_expansion_allowed(maplist(Meta, L1, L2, L3, L4), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(maplist, 5, Proto, GoalName), - append(MetaVars, [L1, L2, L3, L4], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], [], [], []], Base), - append_args(HeadPrefix, [[A1|A1s], [A2|A2s], [A3|A3s], [A4|A4s]], RecursionHead), - append_args(Pred, [A1, A2, A3, A4], Apply), - append_args(HeadPrefix, [A1s, A2s, A3s, A4s], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- Apply, RecursiveCall) - ], Module). - -user:goal_expansion(selectlist(Meta, ListIn, ListOut), Mod, Goal) :- - goal_expansion_allowed(selectlist(Meta, ListIn, ListOut), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(selectlist, 3, Proto, GoalName), - append(MetaVars, [ListIn, ListOut], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], []], Base), - append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead), - append_args(Pred, [In], Apply), - append_args(HeadPrefix, [Ins, NOuts], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - (Apply -> Outs = [In|NOuts]; Outs = NOuts), - RecursiveCall) - ], Module). - -% same as selectlist -user:goal_expansion(include(Meta, ListIn, ListOut), Mod, Goal) :- - goal_expansion_allowed(include(Meta, ListIn, ListOut), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(include, 3, Proto, GoalName), - append(MetaVars, [ListIn, ListOut], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], []], Base), - append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead), - append_args(Pred, [In], Apply), - append_args(HeadPrefix, [Ins, NOuts], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - (Apply -> Outs = [In|NOuts]; Outs = NOuts), - RecursiveCall) - ], Module). - -user:goal_expansion(exclude(Meta, ListIn, ListOut), Mod, Goal) :- - goal_expansion_allowed(exclude(Meta, ListIn, ListOut), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(exclude, 3, Proto, GoalName), - append(MetaVars, [ListIn, ListOut], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], []], Base), - append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead), - append_args(Pred, [In], Apply), - append_args(HeadPrefix, [Ins, NOuts], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - (Apply -> Outs = [In|NOuts]; Outs = NOuts), - RecursiveCall) - ], Module). - -user:goal_expansion(partition(Meta, ListIn, List1, List2), Mod, Goal) :- - goal_expansion_allowed(partition(Meta, ListIn, List1, List2), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(partition, 4, Proto, GoalName), - append(MetaVars, [ListIn, List1, List2], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], [], []], Base), - append_args(HeadPrefix, [[In|Ins], Outs1, Outs2], RecursionHead), - append_args(Pred, [In], Apply), - append_args(HeadPrefix, [Ins, NOuts1, NOuts2], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - (Apply -> Outs1 = [In|NOuts1], Outs2 = NOuts2; Outs1 = NOuts1, Outs2 = [In|NOuts2]), - RecursiveCall) - ], Module). - -user:goal_expansion(partition(Meta, ListIn, List1, List2, List3), Mod, Goal) :- - goal_expansion_allowed(partition(Meta, ListIn, List1, List2, List3), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(partition2, 5, Proto, GoalName), - append(MetaVars, [ListIn, List1, List2, List3], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], [], [], []], Base), - append_args(HeadPrefix, [[In|Ins], Outs1, Outs2, Outs3], RecursionHead), - append_args(Pred, [In,Diff], Apply), - append_args(HeadPrefix, [Ins, NOuts1, NOuts2, NOuts3], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - Apply, - (Diff == (<) -> - Outs1 = [In|NOuts1], - Outs2 = NOuts2, - Outs3 = NOuts3 - ; - Diff == (=) -> - Outs1 = NOuts1, - Outs2 = [In|NOuts2], - Outs3 = NOuts3 - ; - Diff == (>) -> - Outs1 = NOuts1, - Outs2 = NOuts2, - Outs3 = [In|NOuts3] - ; - error:must_be(oneof([<,=,>]), Diff) - ), - RecursiveCall) - ], Module). - -user:goal_expansion(convlist(Meta, ListIn, ListOut), Mod, Goal) :- - goal_expansion_allowed(convlist(Meta, ListIn, ListOut), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(convlist, 3, Proto, GoalName), - append(MetaVars, [ListIn, ListOut], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], []], Base), - append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead), - append_args(Pred, [In, Out], Apply), - append_args(HeadPrefix, [Ins, NOuts], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - (Apply -> Outs = [Out|NOuts]; Outs = NOuts), - RecursiveCall) - ], Module). - -user:goal_expansion(sumlist(Meta, List, AccIn, AccOut), Mod, Goal) :- - goal_expansion_allowed(sumlist(Meta, List, AccIn, AccOut), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(sumlist, 4, Proto, GoalName), - append(MetaVars, [List, AccIn, AccOut], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], Acc, Acc], Base), - append_args(HeadPrefix, [[In|Ins], Acc1, Acc2], RecursionHead), - append_args(Pred, [In, Acc1, Acc3], Apply), - append_args(HeadPrefix, [Ins, Acc3, Acc2], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- Apply, RecursiveCall) - ], Module). - -user:goal_expansion(mapargs(Meta, In, Out), Module, NewGoal) :- - goal_expansion_allowed(mapargs(Meta, In, Out), Module), - ( var(Out) - -> - NewGoal = ( - In =.. [F|InArgs], - maplist(Meta, InArgs, OutArgs), - Out =.. [F|OutArgs] - ) - ; - NewGoal = ( - Out =.. [F|OutArgs], - maplist(Meta, InArgs, OutArgs), - In =.. [F|InArgs] - ) - ). - -user:goal_expansion(sumargs(Meta, Term, AccIn, AccOut), Module, Goal) :- - goal_expansion_allowed(sumargs(Meta, Term, AccIn, AccOut), Module), - Goal = ( - Term =.. [_|TermArgs], - sumlist(Meta, TermArgs, AccIn, AccOut) - ). - -user:goal_expansion(mapnodes(Meta, InTerm, OutTerm), Mod, Goal) :- - goal_expansion_allowed(mapnodes(Meta, InTerm, OutTerm), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(mapnodes, 3, Proto, GoalName), - append(MetaVars, [[InTerm], [OutTerm]], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], []], Base), - append_args(HeadPrefix, [[In|Ins], [Out|Outs]], RecursionHead), - append_args(Pred, [In, Temp], Apply), - append_args(HeadPrefix, [InArgs, OutArgs], SubRecursiveCall), - append_args(HeadPrefix, [Ins, Outs], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - Apply, - (compound(Temp) - -> - Temp =.. [F|InArgs], - SubRecursiveCall, - Out =.. [F|OutArgs] - ; - Out = Temp - ), - RecursiveCall) - ], Module). - -user:goal_expansion(checknodes(Meta, Term), Mod, Goal) :- - goal_expansion_allowed(checknodes(Meta, Term), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(checknodes, 2, Proto, GoalName), - append(MetaVars, [[Term]], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[]], Base), - append_args(HeadPrefix, [[In|Ins]], RecursionHead), - append_args(Pred, [In], Apply), - append_args(HeadPrefix, [Args], SubRecursiveCall), - append_args(HeadPrefix, [Ins], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - Apply, - (compound(In) - -> - In =.. [_|Args],SubRecursiveCall - ; - true - ), - RecursiveCall) - ], Module). - -user:goal_expansion(sumnodes(Meta, Term, AccIn, AccOut), Mod, Goal) :- - goal_expansion_allowed(sumnodes(Meta, Term, AccIn, AccOut), Mod), - callable(Meta), - !, - aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module), - % the new goal - pred_name(sumnodes, 4, Proto, GoalName), - append(MetaVars, [[Term], AccIn, AccOut], GoalArgs), - Goal =.. [GoalName|GoalArgs], - % the new predicate declaration - HeadPrefix =.. [GoalName|PredVars], - append_args(HeadPrefix, [[], Acc, Acc], Base), - append_args(HeadPrefix, [[In|Ins], Acc1, Acc2], RecursionHead), - append_args(Pred, [In, Acc1, Acc3], Apply), - append_args(HeadPrefix, [Args, Acc3, Acc4], SubRecursiveCall), - append_args(HeadPrefix, [Ins, Acc4, Acc2], RecursiveCall), - compile_aux([ - Base, - (RecursionHead :- - Apply, - (compound(In) - -> - In =.. [_|Args],SubRecursiveCall - ; - Acc3 = Acc4 - ), - RecursiveCall) - ], Module). - -:- unhide('$translate_rule'). -% stolen from SWI-Prolog -user:goal_expansion(phrase(NT,Xs), Mod, NTXsNil) :- - user:goal_expansion(phrase(NT,Xs,[]), Mod, NTXsNil). -user:goal_expansion(phrase(NT,Xs0,Xs), Mod, NewGoal) :- - goal_expansion_allowed(phrase(NT,Xs0,Xs), Mod), - Goal = phrase(NT,Xs0,Xs), - nonvar(NT), - catch('$translate_rule'((pseudo_nt --> NT), Rule), - error(Pat,ImplDep), - ( \+ harmless_dcgexception(Pat), - throw(error(Pat,ImplDep)) - )), - Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0), - Goal \== NewGoal0, - % apply translation only if we are safe - \+ contains_illegal_dcgnt(NT), !, - ( var(Xsc), Xsc \== Xs0c - -> Xs = Xsc, NewGoal1 = NewGoal0 - ; NewGoal1 = (NewGoal0, Xsc = Xs) - ), - ( var(Xs0c) - -> Xs0 = Xs0c, - NewGoal = NewGoal1 - ; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal - ). -:- hide('$translate_rule'). %%%%%%%%%%%%%%%%%%%% % utilities @@ -487,18 +74,6 @@ harmless_dcgexception(instantiation_error). % ex: phrase(([1],x:X,[3]),L) harmless_dcgexception(type_error(callable,_)). % ex: phrase(27,L) -%% contains_illegal_dcgnt(+Term) is semidet. -% -% True if Term contains a non-terminal we cannot deal with using -% goal-expansion. The test is too general approximation, but safe. - -contains_illegal_dcgnt(NT) :- - sub_term(I, NT), - nonvar(I), - ( I = ! ; I = phrase(_,_,_) ), !. -% write(contains_illegal_nt(NT)), % JW: we do not want to write -% nl. - '$expand':allowed_expansion(QExpand) :- strip_module(QExpand, Mod, Pred), goal_expansion_allowed(Pred, Mod). diff --git a/library/maplist.yap b/library/maplist.yap index 7b97bf297..ff0a597e1 100644 --- a/library/maplist.yap +++ b/library/maplist.yap @@ -1248,36 +1248,6 @@ goal_expansion(sumnodes(Meta, Term, AccIn, AccOut), Mod:Goal) :- RecursiveCall) ], Mod). -/* -:- unhide('$translate_rule'). -% stolen from SWI-Prolog -user:goal_expansion(phrase(NT,Xs), Mod, NTXsNil) :- - user:goal_expansion(phrase(NT,Xs,[]), Mod, NTXsNil). -user:goal_expansion(phrase(NT,Xs0,Xs), Mod, NewGoal) :- - goal_expansion_allowed, - Goal = phrase(NT,Xs0,Xs), - nonvar(NT), - catch('$translate_rule'((pseudo_nt --> NT), Rule), - error(Pat,ImplDep), - ( \+ harmless_dcgexception(Pat), - throw(error(Pat,ImplDep)) - )), - Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0), - Goal \== NewGoal0, - % apply translation only if we are safe - \+ contains_illegal_dcgnt(NT), !, - ( var(Xsc), Xsc \== Xs0c - -> Xs = Xsc, NewGoal1 = NewGoal0 - ; NewGoal1 = (NewGoal0, Xsc = Xs) - ), - ( var(Xs0c) - -> Xs0 = Xs0c, - NewGoal = NewGoal1 - ; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal - ). -:- hide('$translate_rule'). -*/ - /** @} */ diff --git a/library/maputils.yap b/library/maputils.yap index 262bacc10..5c5648a3e 100644 --- a/library/maputils.yap +++ b/library/maputils.yap @@ -24,6 +24,9 @@ number_of_expansions(0). +% +% compile auxiliary routines for term expansion +% compile_aux([Clause|Clauses], Module) :- % compile the predicate declaration if needed ( Clause = (Head :- _) @@ -83,22 +86,6 @@ transformation_id(Id) :- Id1 is Id+1, assert(number_of_expansions(Id1)). -harmless_dcgexception(instantiation_error). % ex: phrase(([1],x:X,[3]),L) -harmless_dcgexception(type_error(callable,_)). % ex: phrase(27,L) - - -%% contains_illegal_dcgnt(+ Term) is semidet. -% -% `True` if _Term_ contains a non-terminal we cannot deal with using -% goal-expansion. The test is too general approximation, but safe. - -contains_illegal_dcgnt(NT) :- - sub_term(I, NT), - nonvar(I), - ( I = ! ; I = phrase(_,_,_) ), !. -% write(contains_illegal_nt(NT)), % JW: we do not want to write -% nl. - %% goal_expansion_allowed is semidet. % % `True` if we can use From a1022f8237b5928ce68bb25c729ad4b74a9d1b51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:32:26 +0100 Subject: [PATCH 11/25] always deref arguments to built-ins. --- C/cmppreds.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/C/cmppreds.c b/C/cmppreds.c index 693d33f00..700623699 100644 --- a/C/cmppreds.c +++ b/C/cmppreds.c @@ -794,7 +794,9 @@ a_eq(Term t1, Term t2) { CACHE_REGS /* A =:= B */ - int out; + Int out; + t1 = Deref(t1); + t2 = Deref(t2); if (IsVarTerm(t1)) { Yap_Error(INSTANTIATION_ERROR, t1, "=:=/2"); From 4f77281827e94b68506cf3aeb51c5c02a0d310d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:33:22 +0100 Subject: [PATCH 12/25] move docs around. --- C/dbase.c | 133 ++++++++++++++++++++++++++---------------------------- 1 file changed, 64 insertions(+), 69 deletions(-) diff --git a/C/dbase.c b/C/dbase.c index 6562257aa..8f59d4b12 100644 --- a/C/dbase.c +++ b/C/dbase.c @@ -2117,6 +2117,14 @@ p_rcdap( USES_REGS1 ) } /* recorda_at(+DBRef,+Term,-Ref) */ +/** @pred recorda_at(+ _R0_, _T_,- _R_) + + +Makes term _T_ the record preceding record with reference + _R0_, and unifies _R_ with its reference. + + +*/ static Int p_rcda_at( USES_REGS1 ) { @@ -2159,6 +2167,12 @@ p_rcda_at( USES_REGS1 ) } /* recordz(+Functor,+Term,-Ref) */ +/** @pred recordz(+ _K_, _T_,- _R_) + +Makes term _T_ the last record under key _K_ and unifies _R_ +with its reference. + +*/ static Int p_rcdz( USES_REGS1 ) { @@ -2255,6 +2269,14 @@ p_rcdzp( USES_REGS1 ) } /* recordz_at(+Functor,+Term,-Ref) */ +/** @pred recordz_at(+ _R0_, _T_,- _R_) + + +Makes term _T_ the record following record with reference + _R0_, and unifies _R_ with its reference. + + +*/ static Int p_rcdz_at( USES_REGS1 ) { @@ -3747,7 +3769,16 @@ lu_statistics(PredEntry *pe USES_REGS) Yap_unify(ARG4,MkIntegerTerm(isz)); } +/** @pred key_statistics(+ _K_,- _Entries_,- _Size_,- _IndexSize_) + +Returns several statistics for a key _K_. Currently, it says how +many entries we have for that key, _Entries_, what is the +total size spent on entries, _Size_, and what is the amount of +space spent in indices. + + +*/ static Int p_key_statistics( USES_REGS1 ) { @@ -4434,6 +4465,14 @@ p_decrease_reference_counter( USES_REGS1 ) } /* erase(+Ref) */ +/** @pred erase(+ _R_) + + +The term referred to by _R_ is erased from the internal database. If +reference _R_ does not exist in the database, `erase` just fails. + + +*/ static Int p_current_reference_counter( USES_REGS1 ) { @@ -4487,6 +4526,12 @@ p_erase_clause( USES_REGS1 ) } /* eraseall(+Key) */ +/** @pred eraseall(+ _K_) + +All terms belonging to the key `K` are erased from the internal +database. The predicate always succeeds. + +*/ static Int p_eraseall( USES_REGS1 ) { @@ -4549,6 +4594,14 @@ p_eraseall( USES_REGS1 ) /* erased(+Ref) */ +/** @pred erased(+ _R_) + + +Succeeds if the object whose database reference is _R_ has been +erased. + + +*/ static Int p_erased( USES_REGS1 ) { @@ -4678,6 +4731,17 @@ mega_instance(yamop *code, PredEntry *ap USES_REGS) } /* instance(+Ref,?Term) */ +/** @pred instance(+ _R_,- _T_) + + +If _R_ refers to a clause or a recorded term, _T_ is unified +with its most general instance. If _R_ refers to an unit clause + _C_, then _T_ is unified with ` _C_ :- true`. When + _R_ is not a reference to an existing clause or to a recorded term, +this goal fails. + + +*/ static Int p_instance( USES_REGS1 ) { @@ -5581,81 +5645,22 @@ with its reference. */ Yap_InitCPred("recordz", 3, p_rcdz, SyncPredFlag); -/** @pred recordz(+ _K_, _T_,- _R_) - - -Makes term _T_ the last record under key _K_ and unifies _R_ -with its reference. - - -*/ Yap_InitCPred("$still_variant", 2, p_still_variant, SyncPredFlag); Yap_InitCPred("recorda_at", 3, p_rcda_at, SyncPredFlag); -/** @pred recorda_at(+ _R0_, _T_,- _R_) - - -Makes term _T_ the record preceding record with reference - _R0_, and unifies _R_ with its reference. - - -*/ Yap_InitCPred("recordz_at", 3, p_rcdz_at, SyncPredFlag); -/** @pred recordz_at(+ _R0_, _T_,- _R_) - - -Makes term _T_ the record following record with reference - _R0_, and unifies _R_ with its reference. - - -*/ Yap_InitCPred("$recordap", 3, p_rcdap, SyncPredFlag); Yap_InitCPred("$recordzp", 3, p_rcdzp, SyncPredFlag); Yap_InitCPred("$recordap", 4, p_drcdap, SyncPredFlag); Yap_InitCPred("$recordzp", 4, p_drcdzp, SyncPredFlag); Yap_InitCPred("erase", 1, p_erase, SafePredFlag|SyncPredFlag); -/** @pred erase(+ _R_) - - -The term referred to by _R_ is erased from the internal database. If -reference _R_ does not exist in the database, `erase` just fails. - - -*/ Yap_InitCPred("$erase_clause", 2, p_erase_clause, SafePredFlag|SyncPredFlag); Yap_InitCPred("increase_reference_count", 1, p_increase_reference_counter, SafePredFlag|SyncPredFlag); Yap_InitCPred("decrease_reference_count", 1, p_decrease_reference_counter, SafePredFlag|SyncPredFlag); Yap_InitCPred("current_reference_count", 2, p_current_reference_counter, SafePredFlag|SyncPredFlag); Yap_InitCPred("erased", 1, p_erased, TestPredFlag | SafePredFlag|SyncPredFlag); -/** @pred erased(+ _R_) - - -Succeeds if the object whose database reference is _R_ has been -erased. - - -*/ Yap_InitCPred("instance", 2, p_instance, SyncPredFlag); -/** @pred instance(+ _R_,- _T_) - - -If _R_ refers to a clause or a recorded term, _T_ is unified -with its most general instance. If _R_ refers to an unit clause - _C_, then _T_ is unified with ` _C_ :- true`. When - _R_ is not a reference to an existing clause or to a recorded term, -this goal fails. - - -*/ Yap_InitCPred("$instance_module", 2, p_instance_module, SyncPredFlag); Yap_InitCPred("eraseall", 1, p_eraseall, SafePredFlag|SyncPredFlag); -/** @pred eraseall(+ _K_) - - -All terms belonging to the key `K` are erased from the internal -database. The predicate always succeeds. - - -*/ Yap_InitCPred("$record_stat_source", 4, p_rcdstatp, SafePredFlag|SyncPredFlag); Yap_InitCPred("$some_recordedp", 1, p_somercdedp, SafePredFlag|SyncPredFlag); Yap_InitCPred("$first_instance", 3, p_first_instance, SafePredFlag|SyncPredFlag); @@ -5673,16 +5678,6 @@ database. The predicate always succeeds. Yap_InitCPred("$fetch_reference_from_index", 3, p_fetch_reference_from_index, SafePredFlag|SyncPredFlag); Yap_InitCPred("$resize_int_keys", 1, p_resize_int_keys, SafePredFlag|SyncPredFlag); Yap_InitCPred("key_statistics", 4, p_key_statistics, SyncPredFlag); -/** @pred key_statistics(+ _K_,- _Entries_,- _Size_,- _IndexSize_) - - -Returns several statistics for a key _K_. Currently, it says how -many entries we have for that key, _Entries_, what is the -total size spent on entries, _Size_, and what is the amount of -space spent in indices. - - -*/ Yap_InitCPred("$lu_statistics", 5, p_lu_statistics, SyncPredFlag); Yap_InitCPred("total_erased", 4, p_total_erased, SyncPredFlag); Yap_InitCPred("key_erased_statistics", 5, p_key_erased_statistics, SyncPredFlag); From 48b1cf5d45127330c587793161467eb3a4e553fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:34:03 +0100 Subject: [PATCH 13/25] store away all directives we find. --- pl/boot.yap | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/pl/boot.yap b/pl/boot.yap index e0115243a..62d563a4a 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -688,8 +688,17 @@ number of steps. % % but YAP and SICStus does. % - '$process_directive'(G, _, M, VL, Pos) :- - ( '$execute'(M:G) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ). + '$process_directive'(G, Mode, M, VL, Pos) :- + ( '$undefined'('$save_directive'(G, Mode, M, VL, Pos),prolog) -> + true + ; + '$save_directive'(G, Mode, M, VL, Pos) + -> + true + ; + true + ), + ( '$execute'(M:G) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ). '$continue_with_command'(Where,V,'$stream_position'(C,_P,A1,A2,A3),'$source_location'(_F,L):G,Source) :- !, '$continue_with_command'(Where,V,'$stream_position'(C,L,A1,A2,A3),G,Source). From 2960f81e041d309bc42c2e44bf7d844b5bffc0c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:34:51 +0100 Subject: [PATCH 14/25] just say cmp preds are binary. --- C/init.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/C/init.c b/C/init.c index 8c6392359..fdfde20c2 100755 --- a/C/init.c +++ b/C/init.c @@ -627,7 +627,7 @@ Yap_InitCmpPred(const char *Name, UInt Arity, CmpPredicate cmp_code, UInt flags) return; } } - if (pe->PredFlags & CPredFlag) { + if (pe->PredFlags & BinaryPredFlag) { flags = update_flags_from_prolog(flags, pe); p_code = pe->CodeOfPred; /* already exists */ @@ -651,7 +651,7 @@ Yap_InitCmpPred(const char *Name, UInt Arity, CmpPredicate cmp_code, UInt flags) } } } - pe->PredFlags = flags | StandardPredFlag | CPredFlag; + //pe->PredFlags = flags | StandardPredFlag; pe->CodeOfPred = p_code; pe->cs.d_code = cmp_code; pe->ModuleOfPred = CurrentModule; @@ -1054,6 +1054,7 @@ InitSWIAtoms(void) int j=0; MaxAtomTranslations = 2*N_SWI_ATOMS ; SWI_Atoms = (Atom *)malloc(sizeof(Atom)*MaxAtomTranslations); + SWI_Functors = (Functor *)malloc(sizeof(Functor)*2*N_SWI_ATOMS); #include "iswiatoms.h" Yap_InitSWIHash(); ATOM_ = PL_new_atom(""); From b8f1ee4a75f560d3b4c87f752ecedf62f45cc49a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:35:38 +0100 Subject: [PATCH 15/25] extend nb_setarag/3 to call a default case at initialization, ie, nb_getval(a, X, X=start). and just that. --- C/globals.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/C/globals.c b/C/globals.c index 56af0406a..d1fd726da 100644 --- a/C/globals.c +++ b/C/globals.c @@ -1370,7 +1370,15 @@ p_nb_getval( USES_REGS1 ) } ge = FindGlobalEntry(AtomOfTerm(t) PASS_REGS); if (!ge) { - return Yap_unify(TermNil, ARG3); + Term t3 = Deref(ARG3); + if (IsVarTerm(t3)) + return FALSE; + if (IsApplTerm(t3)) { + if (FunctorOfTerm(t3) == FunctorEq) + return Yap_unify( ArgOfTerm(1, t3) , ArgOfTerm(2, t3) ); + return FALSE; + } + return Yap_unify(t3, MkAtomTerm(AtomTrue)); } READ_LOCK(ge->GRWLock); to = ge->global; From b793ffb71a6e5f53d78d1f58b20c81b002111c6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:37:12 +0100 Subject: [PATCH 16/25] remove debugging stuff. --- CXX/yapi.cpp | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/CXX/yapi.cpp b/CXX/yapi.cpp index fa94824ce..11cb87f5a 100644 --- a/CXX/yapi.cpp +++ b/CXX/yapi.cpp @@ -509,9 +509,8 @@ bool YAPQuery::next() if (q_state == 0) { // extern void toggle_low_level_trace(void); //toggle_low_level_trace(); - { CACHE_REGS __android_log_print(ANDROID_LOG_ERROR, __FUNCTION__, "next %p", HR) ; } result = (bool)YAP_EnterGoal((YAP_PredEntryPtr)ap, q_g, &q_h); - { CACHE_REGS __android_log_print(ANDROID_LOG_ERROR, __FUNCTION__, "done") ; } + } else { LOCAL_AllowRestart = this->q_open; result = (bool)YAP_RetryGoal(&q_h); From b1a6f092fd2e910072cb112d393c593b9c7fbcec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:38:23 +0100 Subject: [PATCH 17/25] fix compiltion of binary tests to use a long instruction. --- C/amasm.c | 67 ++++++++++----------- C/compiler.c | 164 +++++++++++++++++++++++++++++++++------------------ C/grow.c | 6 +- 3 files changed, 142 insertions(+), 95 deletions(-) diff --git a/C/amasm.c b/C/amasm.c index eae3a6ac7..e0fa64037 100755 --- a/C/amasm.c +++ b/C/amasm.c @@ -259,7 +259,6 @@ static yamop *a_try(op_numbers, CELL, CELL, yamop *, int, struct intermediates * static yamop *a_either(op_numbers, CELL, CELL, yamop *, int, struct intermediates *); #endif /* YAPOR */ static yamop *a_gl(op_numbers, yamop *, int, struct PSEUDO *, struct intermediates * CACHE_TYPE); -static yamop *a_bfunc(CELL, clause_info *, yamop *, int, struct intermediates *); static COUNT compile_cmp_flags(char *); static yamop *a_igl(CELL, op_numbers, yamop *, int, struct intermediates *); @@ -1622,65 +1621,63 @@ Yap_compile_cmp_flags(PredEntry *pred) } static yamop * -a_bfunc(CELL pred, clause_info *clinfo, yamop *code_p, int pass_no, struct intermediates *cip) +a_bfunc(CELL a1, CELL a2, PredEntry *pred, clause_info *clinfo, yamop *code_p, int pass_no, struct intermediates *cip) { - Ventry *ve = (Ventry *) cip->cpc->rnd1; - OPREG var_offset; - int is_y_var = (ve->KindOfVE == PermVar); - - var_offset = Var_Ref(ve, is_y_var); - if (ve->KindOfVE == PermVar) { - yslot v1 = emit_yreg(var_offset); - cip->cpc = cip->cpc->nextInst; - ve = (Ventry *) cip->cpc->rnd1; - is_y_var = (ve->KindOfVE == PermVar); - var_offset = Var_Ref(ve, is_y_var); - if (is_y_var) { + Ventry *ve1 = (Ventry *)a1; + Ventry *ve2 = (Ventry *)a2; + OPREG var_offset1; + int is_y_var = (ve1->KindOfVE == PermVar); + + var_offset1 = Var_Ref(ve1, is_y_var); + if (ve1->KindOfVE == PermVar) { + yslot v1 = emit_yreg(var_offset1); + bool is_y_var2 = (ve2->KindOfVE == PermVar); + OPREG var_offset2 = Var_Ref(ve2, is_y_var2); + if (is_y_var2) { if (pass_no) { code_p->opc = emit_op(_call_bfunc_yy); - code_p->y_u.plyys.p = RepPredProp(((Prop)pred)); + code_p->y_u.plyys.p = pred; code_p->y_u.plyys.f = emit_fail(cip); code_p->y_u.plyys.y1 = v1; - code_p->y_u.plyys.y2 = emit_yreg(var_offset); + code_p->y_u.plyys.y2 = emit_yreg(var_offset2); code_p->y_u.plyys.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE); } GONEXT(plyys); } else { if (pass_no) { code_p->opc = emit_op(_call_bfunc_yx); - code_p->y_u.plxys.p = RepPredProp(((Prop)pred)); + code_p->y_u.plxys.p = pred; code_p->y_u.plxys.f = emit_fail(cip); - code_p->y_u.plxys.x = emit_xreg(var_offset); + code_p->y_u.plxys.x = emit_xreg(var_offset2); code_p->y_u.plxys.y = v1; - code_p->y_u.plxys.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE); + code_p->y_u.plxys.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE); } GONEXT(plxys); } } else { - wamreg x1 = emit_xreg(var_offset); - OPREG var_offset; + wamreg x1 = emit_xreg(var_offset1); + OPREG var_offset2; - cip->cpc = cip->cpc->nextInst; - ve = (Ventry *) cip->cpc->rnd1; - is_y_var = (ve->KindOfVE == PermVar); - var_offset = Var_Ref(ve, is_y_var); - if (is_y_var) { + bool is_y_var2 = (ve2->KindOfVE == PermVar); + var_offset2 = Var_Ref(ve2, is_y_var2); + if (is_y_var2) { if (pass_no) { code_p->opc = emit_op(_call_bfunc_xy); - code_p->y_u.plxys.p = RepPredProp(((Prop)pred)); + code_p->y_u.plxys.p = pred; code_p->y_u.plxys.f = emit_fail(cip); code_p->y_u.plxys.x = x1; - code_p->y_u.plxys.y = emit_yreg(var_offset); + code_p->y_u.plxys.y = emit_yreg(var_offset2); code_p->y_u.plxys.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE); } GONEXT(plxys); } else { if (pass_no) { + // printf(" %p --- %p\n", x1, emit_xreg(var_offset2) ); code_p->opc = emit_op(_call_bfunc_xx); - code_p->y_u.plxxs.p = RepPredProp(((Prop)pred)); + code_p->y_u.plxxs.p = pred; code_p->y_u.plxxs.f = emit_fail(cip); code_p->y_u.plxxs.x1 = x1; - code_p->y_u.plxxs.x2 = emit_xreg(var_offset); + code_p->y_u.plxxs.x2 = emit_xreg(var_offset2); code_p->y_u.plxxs.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE); } GONEXT(plxxs); @@ -3685,13 +3682,8 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp case count_retry_op: code_p = a_pl(_count_retry, (PredEntry *)(cip->cpc->rnd1), code_p, pass_no); break; - case fetch_args_for_bccall_op: - if (cip->cpc->nextInst->op != bccall_op) { - Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "compiling binary test", (int) cip->cpc->op); - save_machine_regs(); - siglongjmp(cip->CompilerBotch, 1); - } - code_p = a_bfunc(cip->cpc->nextInst->rnd2, &clinfo, code_p, pass_no, cip); + case bccall_op: + code_p = a_bfunc(cip->cpc->rnd1, cip->cpc->rnd3, (PredEntry *)(cip->cpc->rnd5), &clinfo, code_p, pass_no, cip); break; case align_float_op: /* install a blob */ @@ -3888,6 +3880,7 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates DBTerm *x; StaticClause *cl; UInt osize; + if (ap->PredFlags & SourcePredFlag ) printf("BINGO\n"); if(!(x = fetch_clause_space(&t, size, cip, &osize PASS_REGS))) { return NULL; } diff --git a/C/compiler.c b/C/compiler.c index 3ba591cc2..696ebf23e 100644 --- a/C/compiler.c +++ b/C/compiler.c @@ -236,7 +236,7 @@ static void c_bifun(basic_preds, Term, Term, Term, Term, Term, compiler_struct * static void c_goal(Term, Term, compiler_struct *); static void c_body(Term, Term, compiler_struct *); static void c_head(Term, compiler_struct *); -static int usesvar(compiler_vm_op); +static bool usesvar(compiler_vm_op); static CELL *init_bvarray(int, compiler_struct *); #ifdef DEBUG static void clear_bvarray(int, CELL *, compiler_struct *); @@ -446,12 +446,6 @@ c_var(Term t, Int argno, unsigned int arity, unsigned int level, compiler_struct Yap_emit(f_val_op, t, (CELL)arity, &cglobs->cint); } break; - case bt1_flag: - Yap_emit(fetch_args_for_bccall_op, t, 0, &cglobs->cint); - break; - case bt2_flag: - Yap_emit(bccall_op, t, (CELL)cglobs->current_p0, &cglobs->cint); - break; default: #ifdef SFUNC if (argno < 0) { @@ -483,6 +477,24 @@ c_var(Term t, Int argno, unsigned int arity, unsigned int level, compiler_struct tag_var(t, new, cglobs); } +// built-in like X >= Y. +static void +c_2vars(int op, Term t1, Int argno1, Term t2, Int argno2, CELL extra, unsigned int arity, unsigned int level, compiler_struct *cglobs) +{ + int new1 = check_var((t1 = Deref(t1)), level, argno1, cglobs); + int new2 = check_var((t2 = Deref(t2)), level, argno2, cglobs); + + switch (op) { + case bt_flag: + Yap_emit_5ops(bccall_op, t1, argno1, t2, argno2, extra, &cglobs->cint); + break; + default: + return; + } + tag_var(t1, new1, cglobs); + tag_var(t2, new2, cglobs); +} + static void reset_vars(Ventry *vtable) { @@ -1876,9 +1888,8 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) v->FlagsOfVE |= SafeVar; return; } - else if (p->PredFlags & AsmPredFlag) { + else if (p->PredFlags & (AsmPredFlag)) { basic_preds op = p->PredFlags & 0x7f; - if (profiling) Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint); else if (call_counting) @@ -1941,7 +1952,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) #ifdef BEAM else if (p->PredFlags & BinaryPredFlag && !EAM) { #else - else if (p->PredFlags & BinaryPredFlag) { + else if (p->PredFlags & BinaryPredFlag ) { #endif CACHE_REGS Term a1 = ArgOfTerm(1,Goal); @@ -1949,33 +1960,25 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) if (IsVarTerm(a1) && !IsNewVar(a1)) { Term a2 = ArgOfTerm(2,Goal); if (IsVarTerm(a2) && !IsNewVar(a2)) { - if (IsNewVar(a2)) { - LOCAL_Error_TYPE = INSTANTIATION_ERROR; - LOCAL_Error_Term = a2; - LOCAL_ErrorMessage = LOCAL_ErrorSay; - sprintf(LOCAL_ErrorMessage, "compiling %s/2 with second arg unbound", RepAtom(NameOfFunctor(p->FunctorOfPred))->StrOfAE); - save_machine_regs(); - siglongjmp(cglobs->cint.CompilerBotch,1); - } - c_var(a1, bt1_flag, 2, 0, cglobs); cglobs->current_p0 = p0; - c_var(a2, bt2_flag, 2, 0, cglobs); + c_2vars(bt_flag, a1, 0, a2, 0, (CELL)p0, 0, 0, cglobs); } else { Term t2 = MkVarTerm(); + //c_var(t2, --cglobs->tmpreg, 0, 0, cglobs); if (HR == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } - c_eq(t2, a2, cglobs); - c_var(a1, bt1_flag, 2, 0, cglobs); cglobs->current_p0 = p0; - c_var(t2, bt2_flag, 2, 0, cglobs); + c_eq(t2, a2, cglobs); + c_2vars(bt_flag, a1, 0, t2, 0, (CELL)p0, 0, 0, cglobs); } } else { Term a2 = ArgOfTerm(2,Goal); Term t1 = MkVarTerm(); + //c_var(t1, --cglobs->tmpreg, 0, 0, cglobs); if (HR == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); @@ -1984,21 +1987,20 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) c_eq(t1, a1, cglobs); if (IsVarTerm(a2) && !IsNewVar(a2)) { - c_var(t1, bt1_flag, 2, 0, cglobs); cglobs->current_p0 = p0; - c_var(a2, bt2_flag, 2, 0, cglobs); + c_2vars(bt_flag, t1, 0, a2, 0, (CELL)p0, 0, 0, cglobs); } else { Term t2 = MkVarTerm(); + // c_var(t2, --cglobs->tmpreg, 0, 0, cglobs); if (HR == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } c_eq(t2, a2, cglobs); - c_var(t1, bt1_flag, 2, 0, cglobs); cglobs->current_p0 = p0; - c_var(t2, bt2_flag, 2, 0, cglobs); + c_2vars(bt_flag, t1, 0, t2, 0, (CELL)p0, 0, 0, cglobs); } } if (cglobs->onlast) { @@ -2183,11 +2185,11 @@ c_head(Term t, compiler_struct *cglobs) } -inline static int +inline static bool usesvar(compiler_vm_op ic) { if (ic >= get_var_op && ic <= put_val_op) - return TRUE; + return true; switch (ic) { case save_b_op: case commit_b_op: @@ -2196,21 +2198,36 @@ usesvar(compiler_vm_op ic) case save_pair_op: case f_val_op: case f_var_op: - case fetch_args_for_bccall_op: case bccall_op: - return TRUE; + return true; default: break; } #ifdef SFUNC if (ic >= unify_s_var_op && ic <= write_s_val_op) - return TRUE; + return true; #endif return ((ic >= unify_var_op && ic <= write_val_op) || (ic >= unify_last_var_op && ic <= unify_last_val_op)); } +inline static bool + uses_this_var(PInstr *pc, Term arg) +{ + compiler_vm_op ic = pc->op; + + if (pc->rnd1 != arg) + return arg == pc->rnd3 && ic == bccall_op; + return usesvar( ic ); +} + +inline static bool +usesvar2(compiler_vm_op ic) +{ + return ic == bccall_op; +} + /* * Do as in the traditional WAM and make sure voids are in * environments @@ -2224,6 +2241,34 @@ typedef struct env_tmp { } EnvTmp; #endif + +static void + tag_use(Ventry *v USES_REGS) +{ +#ifdef BEAM + if (EAM) { + if (v->NoOfVE == Unassigned || v->KindOfVE!=PermVar) { + v->NoOfVE = PermVar | (LOCAL_nperm++); + v->KindOfVE = PermVar; + v->FlagsOfVE |= PermFlag; + } + } +#endif + if (v->NoOfVE == Unassigned) { + if ((v->AgeOfVE > 1 && (v->AgeOfVE > v->FirstOfVE)) + || v->KindOfVE == PermVar /* + * * || (v->FlagsOfVE & NonVoid && !(v->FlagsOfVE & + * * OnHeadFlag)) + */ ) { + v->NoOfVE = PermVar | (LOCAL_nperm++); + v->KindOfVE = PermVar; + v->FlagsOfVE |= PermFlag; + } else { + v->NoOfVE = v->KindOfVE = TempVar; + } + } +} + static void AssignPerm(PInstr *pc, compiler_struct *cglobs) { @@ -2277,28 +2322,12 @@ AssignPerm(PInstr *pc, compiler_struct *cglobs) if (uses_var) { Ventry *v = (Ventry *) (pc->rnd1); -#ifdef BEAM - if (EAM) { - if (v->NoOfVE == Unassigned || v->KindOfVE!=PermVar) { - v->NoOfVE = PermVar | (LOCAL_nperm++); - v->KindOfVE = PermVar; - v->FlagsOfVE |= PermFlag; - } - } -#endif - if (v->NoOfVE == Unassigned) { - if ((v->AgeOfVE > 1 && (v->AgeOfVE > v->FirstOfVE)) - || v->KindOfVE == PermVar /* - * * || (v->FlagsOfVE & NonVoid && !(v->FlagsOfVE & - * * OnHeadFlag)) - */ ) { - v->NoOfVE = PermVar | (LOCAL_nperm++); - v->KindOfVE = PermVar; - v->FlagsOfVE |= PermFlag; - } else { - v->NoOfVE = v->KindOfVE = TempVar; - } + tag_use(v PASS_REGS); + if (usesvar2(pc->op) ) { + Ventry *v2 = (Ventry *) (pc->rnd3); + tag_use(v2 PASS_REGS); } + } else if (pc->op == empty_call_op) { pc->rnd2 = LOCAL_nperm; } else if (pc->op == call_op || pc->op == either_op || pc->op == orelse_op || pc->op == push_or_op) { @@ -2357,7 +2386,6 @@ clear_bvarray(int var, CELL *bvarray LOCAL_Error_TYPE = INTERNAL_COMPILER_ERROR; LOCAL_Error_Term = TermNil; LOCAL_ErrorMessage = "compiler internal error: variable initialised twice"; - fprintf(stderr," vsc: compiling7\n"); save_machine_regs(); siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); } @@ -2488,6 +2516,22 @@ CheckUnsafe(PInstr *pc, compiler_struct *cglobs) } break; } + case bccall_op: + { + Ventry *v = (Ventry *) (pc->rnd1), + *v3 = (Ventry *) (pc->rnd3); + + if ( (v->FlagsOfVE & PermFlag && pc == v->FirstOpForV) || + (v3->FlagsOfVE & PermFlag && pc == v3->FirstOpForV) ) { + CACHE_REGS + LOCAL_Error_TYPE = INTERNAL_COMPILER_ERROR; + LOCAL_Error_Term = TermNil; + LOCAL_ErrorMessage = "comparison should not have first instance of variables"; + save_machine_regs(); + siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); + } + } + break; case put_var_op: case get_var_op: case save_b_op: @@ -2625,6 +2669,10 @@ CheckVoids(compiler_struct *cglobs) case get_list_op: case get_struct_op: cglobs->Uses[cpc->rnd2] = 1; + break; + case bccall_op: + cglobs->Uses[cpc->rnd2] = 1; + cglobs->Uses[cpc->rnd4] = 1; default: break; } @@ -2676,7 +2724,9 @@ checktemp(Int arg, Int rn, compiler_vm_op ic, compiler_struct *cglobs) n = v->RCountOfVE - 1; while (q != v->LastOpForV && (q = q->nextInst) != NIL) { if (q->rnd2 <= 0); /* don't try to reuse REGISTER 0 */ - else if (usesvar(ic = q->op) && arg == q->rnd1) { + else if ((usesvar(ic = q->op) && arg == q->rnd1) || + (ic == bccall_op && arg == q->rnd3)/*uses_this_var(q, arg)*/) { + ic = q->op; --n; if (ic == put_val_op) { if (target1 == cglobs->MaxCTemps && Needed[q->rnd2] == 0) @@ -2963,9 +3013,11 @@ c_layout(compiler_struct *cglobs) case unify_s_var_op: case unify_s_val_op: #endif - case fetch_args_for_bccall_op: + checktemp(arg, rn, ic, cglobs); + break; case bccall_op: checktemp(arg, rn, ic, cglobs); + checktemp(cglobs->cint.cpc->rnd3, cglobs->cint.cpc->rnd4, ic, cglobs); break; case get_atom_op: case get_num_op: diff --git a/C/grow.c b/C/grow.c index a8bb19a69..b0bb64523 100755 --- a/C/grow.c +++ b/C/grow.c @@ -1079,8 +1079,6 @@ fix_compiler_instructions(PInstr *pcpc USES_REGS) case write_local_op: case f_var_op: case f_val_op: - case fetch_args_for_bccall_op: - case bccall_op: case save_pair_op: case save_appl_op: case save_b_op: @@ -1090,6 +1088,10 @@ fix_compiler_instructions(PInstr *pcpc USES_REGS) case fetch_args_vc_op: pcpc->rnd1 = GlobalAdjust(pcpc->rnd1); break; + case bccall_op: + pcpc->rnd1 = GlobalAdjust(pcpc->rnd1); + pcpc->rnd3 = GlobalAdjust(pcpc->rnd3); + break; case get_float_op: case put_float_op: case get_longint_op: From 5bae8321d77a94c12d8ce93a5f2c8d641770ca09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:39:45 +0100 Subject: [PATCH 18/25] move gramar preprocessing here. --- pl/arith.yap | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 75 insertions(+), 3 deletions(-) diff --git a/pl/arith.yap b/pl/arith.yap index 98c1dab89..43daba466 100644 --- a/pl/arith.yap +++ b/pl/arith.yap @@ -28,7 +28,6 @@ expand_expr/5, expand_expr/6] ). - :- use_system_module( '$_errors', ['$do_error'/2]). :- use_system_module( '$_modules', ['$clean_cuts'/2]). @@ -60,8 +59,7 @@ */ -/** - @pred expand_exprs(- _O_,+ _N_) +/** @pred expand_exprs(- _O_,+ _N_) Control term expansion during compilation. Enables low-level optimizations. It reports the current state by @@ -86,6 +84,7 @@ expand_exprs(Old,New) :- After a call to this predicate, arithmetical expressions will be compiled. (see example below). This is the default behavior. */ + compile_expressions :- set_value('$c_arith',true). /** @pred do_not_compile_expressions @@ -198,6 +197,31 @@ do_c_built_in(Comp0, _, R) :- % now, do it for comparisons expand_expr(F, Q, V), '$do_and'(P, Q, R0), '$do_and'(R0, Comp, R). +do_c_built_in(phrase(NT,Xs), NTXsNil) :- + '$_arith':do_c_built_in(phrase(NT,Xs,[]), NTXsNil). + +do_c_built_in(phrase(NT,Xs0,Xs), Mod, NewGoal) :- + '$goal_expansion_allowed'(phrase(NT,Xs0,Xs), Mod), + Goal = phrase(NT,Xs0,Xs), + callable(NT), + catch('$translate_rule'((pseudo_nt --> NT), Rule), + error(Pat,ImplDep), + ( \+ '$harmless_dcgexception'(Pat), + throw(error(Pat,ImplDep)) + )), + Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0), + Goal \== NewGoal0, + % apply translation only if we are safe + \+ '$contains_illegal_dcgnt'(NT), !, + ( var(Xsc), Xsc \== Xs0c + -> Xs = Xsc, NewGoal1 = NewGoal0 + ; NewGoal1 = (NewGoal0, Xsc = Xs) + ), + ( var(Xs0c) + -> Xs0 = Xs0c, + NewGoal = NewGoal1 + ; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal + ). do_c_built_in(P, _, P). do_c_built_metacall(G1, Mod, '$execute_wo_mod'(G1,Mod)) :- @@ -369,6 +393,54 @@ expand_expr(Op, X, Y, O, Q, P) :- '$preprocess_args_for_non_commutative'(X, Y, Z, W, E) :- '$do_and'(Z = X, Y = W, E). + +do_c_built_in(phrase(NT,Xs), NTXsNil) :- + '$_arith':do_c_built_in(phrase(NT,Xs,[]), NTXsNil). + +do_c_built_in(phrase(NT,Xs0,Xs), Mod, NewGoal) :- + '$goal_expansion_allowed'(phrase(NT,Xs0,Xs), Mod), + Goal = phrase(NT,Xs0,Xs), + callable(NT), + catch('$translate_rule'((pseudo_nt --> NT), Rule), + error(Pat,ImplDep), + ( \+ '$harmless_dcgexception'(Pat), + throw(error(Pat,ImplDep)) + )), + Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0), + Goal \== NewGoal0, + % apply translation only if we are safe + \+ '$contains_illegal_dcgnt'(NT), !, + ( var(Xsc), Xsc \== Xs0c + -> Xs = Xsc, NewGoal1 = NewGoal0 + ; NewGoal1 = (NewGoal0, Xsc = Xs) + ), + ( var(Xs0c) + -> Xs0 = Xs0c, + NewGoal = NewGoal1 + ; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal + ). + +'$goal_expansion_allowed'(phrase(_NT,_Xs0,_Xs), _Mod). + +%% contains_illegal_dcgnt(+Term) is semidet. +% +% True if Term contains a non-terminal we cannot deal with using +% goal-expansion. The test is too general approximation, but safe. + +'$contains_illegal_dcgnt'(NT) :- + functor(NT, _, A), + between(1, A, I), + arg(I, NT), + nonvar(I), + ( I = ! ; I = phrase(_,_,_) ), !. +% write(contains_illegal_nt(NT)), % JW: we do not want to write +% nl. + +'$harmless_dcgexception'(instantiation_error). % ex: phrase(([1],x:X,[3]),L) +'$harmless_dcgexception'(type_error(callable,_)). % ex: phrase(27,L) + + + /** @} From fe0e12b0300a8f6bc7db37bb9604df53a4f2b68f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:40:45 +0100 Subject: [PATCH 19/25] store loaded files state. --- pl/load_foreign.yap | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/pl/load_foreign.yap b/pl/load_foreign.yap index 20e0ed4a2..618a07b41 100644 --- a/pl/load_foreign.yap +++ b/pl/load_foreign.yap @@ -61,15 +61,15 @@ load_foreign_files(Objs,Libs,Entry) :- '$check_objs_for_load_foreign_files'(Objs,NewObjs,load_foreign_files(Objs,Libs,Entry)), '$check_libs_for_load_foreign_files'(Libs,NewLibs,load_foreign_files(Objs,Libs,Entry)), '$check_entry_for_load_foreign_files'(Entry,load_foreign_files(Objs,Libs,Entry)), + '$current_module'( M ), '$load_foreign_files'(NewObjs,NewLibs,Entry), ignore( recordzifnot( '$foreign', M:'$foreign'(Objs,Libs,Entry), _) ), ( - prolog_load_context(file, F), - prolog_load_context(module, M) + prolog_load_context(file, F) -> - ignore( recordzifnot( '$load_foreign_done', [F, M], _) ) - ; - true + ignore( recordzifnot( '$load_foreign_done', [F, M], _) ) + ; + true ), !. '$check_objs_for_load_foreign_files'(V,_,G) :- var(V), !, From 5a40f834f1323b8b743cceeb0350dd132e5fd0ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:41:41 +0100 Subject: [PATCH 20/25] push directives to as early as possible. --- pl/init.yap | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pl/init.yap b/pl/init.yap index 1b390d77c..8d1527f35 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -118,10 +118,10 @@ otherwise. :- bootstrap('os.yap'). :- bootstrap('absf.yap'). -:- [ 'utils.yap', +:- [ 'directives.yap', + 'utils.yap', 'control.yap', 'arith.yap', - 'directives.yap', 'flags.yap' ]. From 2e43165a68a209506afbb8d685ee90525cd708ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:48:47 +0100 Subject: [PATCH 21/25] fix debugging message. --- C/amasm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/C/amasm.c b/C/amasm.c index e0fa64037..a897490d9 100755 --- a/C/amasm.c +++ b/C/amasm.c @@ -3880,7 +3880,7 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates DBTerm *x; StaticClause *cl; UInt osize; - if (ap->PredFlags & SourcePredFlag ) printf("BINGO\n"); + if(!(x = fetch_clause_space(&t, size, cip, &osize PASS_REGS))) { return NULL; } From 1cbc0705c69142432daa56fc04edadf98ec907b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:50:19 +0100 Subject: [PATCH 22/25] syntax changes. --- pl/dbload.yap | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pl/dbload.yap b/pl/dbload.yap index 77a601e9d..a377d9745 100644 --- a/pl/dbload.yap +++ b/pl/dbload.yap @@ -87,7 +87,7 @@ dbload(F, _, G) :- '$do_error'(type_error(atom,F),G). do_dbload(F0, M0, G) :- - '$full_filename'(F0,F,G), + '$full_filename'(F0, F, G), assert(dbprocess(F, M0)), open(F, read, R), check_dbload_stream(R, M0), From a306d0b0ee118735004aeb2cd1f8b33cee58308c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:52:54 +0100 Subject: [PATCH 23/25] improve messages for cosulting. --- pl/messages.yap | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pl/messages.yap b/pl/messages.yap index 68fc6189f..1879e853a 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -97,8 +97,8 @@ generate_message('$abort') --> !, generate_message(abort(user)) --> !, ['YAP execution aborted']. generate_message(loading(_,F)) --> F == user, !. -generate_message(loading(What,AbsoluteFileName)) --> !, - [ '~a ~a...' - [What, AbsoluteFileName] ]. +generate_message(loading(What,FileName)) --> !, + [ '~a ~w...' - [What, FileName] ]. generate_message(loaded(_,user,_,_,_)) --> !. generate_message(loaded(included,AbsoluteFileName,Mod,Time,Space)) --> !, [ '~a included in module ~a, ~d msec ~d bytes' - [AbsoluteFileName,Mod,Time,Space] ]. From ef479f00dc8fdcdf15f102b2c41b26218a9ad13b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:55:47 +0100 Subject: [PATCH 24/25] make grammar a module. --- pl/grammar.yap | 218 ++++++++++++++++++++++++------------------------- 1 file changed, 107 insertions(+), 111 deletions(-) diff --git a/pl/grammar.yap b/pl/grammar.yap index 2407137b6..9d828fa36 100644 --- a/pl/grammar.yap +++ b/pl/grammar.yap @@ -61,19 +61,19 @@ Grammar related built-in predicates: */ -:- system_module( '$_grammar', [!/2, - (',')/4, - (->)/4, - ('.')/4, - (;)/4, - 'C'/3, - []/2, - []/4, - (\+)/3, - phrase/2, - phrase/3, - {}/3, - ('|')/4], ['$translate_rule'/2]). +:- module( '$_grammar', [!/2, +- (',')/4, +- (->)/4, +- ('.')/4, +- (;)/4, +- 'C'/3, +- []/2, +- []/4, +- (\+)/3, +- phrase/2, +- phrase/3, +- {}/3, +- ('|')/4]). :- use_system_module( '$_errors', ['$do_error'/2]). @@ -89,41 +89,41 @@ Grammar related built-in predicates: Also, phrase/2-3 check their first argument. */ -'$translate_rule'((LP-->RP), (NH:-B)) :- - '$t_head'(LP, NH, NGs, S, SR, (LP-->RP)), +prolog:'$translate_rule'((LP-->RP), (NH:-B)) :- + t_head(LP, NH, NGs, S, SR, (LP-->RP)), (var(NGs) -> - '$t_body'(RP, _, last, S, SR, B1) + t_body(RP, _, last, S, SR, B1) ; - '$t_body'((RP,{NGs}), _, last, S, SR, B1) + t_body((RP,{NGs}), _, last, S, SR, B1) ), - '$t_tidy'(B1, B). + t_tidy(B1, B). -'$t_head'(V, _, _, _, _, G0) :- var(V), !, +t_head(V, _, _, _, _, G0) :- var(V), !, '$do_error'(instantiation_error,G0). -'$t_head'((H,List), NH, NGs, S, S1, G0) :- !, - '$t_hgoal'(H, NH, S, SR, G0), - '$t_hlist'(List, S1, SR, NGs, G0). -'$t_head'(H, NH, _, S, SR, G0) :- - '$t_hgoal'(H, NH, S, SR, G0). +t_head((H,List), NH, NGs, S, S1, G0) :- !, + t_hgoal(H, NH, S, SR, G0), + t_hlist(List, S1, SR, NGs, G0). +t_head(H, NH, _, S, SR, G0) :- + t_hgoal(H, NH, S, SR, G0). -'$t_hgoal'(V, _, _, _, G0) :- var(V), !, +t_hgoal(V, _, _, _, G0) :- var(V), !, '$do_error'(instantiation_error,G0). -'$t_hgoal'(M:H, M:NH, S, SR, G0) :- !, - '$t_hgoal'(H, NH, S, SR, G0). -'$t_hgoal'(H, NH, S, SR, _) :- - '$extend'([S,SR],H,NH). +t_hgoal(M:H, M:NH, S, SR, G0) :- !, + t_hgoal(H, NH, S, SR, G0). +t_hgoal(H, NH, S, SR, _) :- + extend([S,SR],H,NH). -'$t_hlist'(V, _, _, _, G0) :- var(V), !, +t_hlist(V, _, _, _, G0) :- var(V), !, '$do_error'(instantiation_error,G0). -'$t_hlist'([], _, _, true, _). -'$t_hlist'(String, S0, SR, SF, G0) :- string(String), !, +t_hlist([], _, _, true, _). +t_hlist(String, S0, SR, SF, G0) :- string(String), !, string_codes( String, X ), - '$t_hlist'( X, S0, SR, SF, G0). -'$t_hlist'([H], S0, SR, ('C'(SR,H,S0)), _) :- !. -'$t_hlist'([H|List], S0, SR, ('C'(SR,H,S1),G0), Goal) :- !, - '$t_hlist'(List, S0, S1, G0, Goal). -'$t_hlist'(T, _, _, _, Goal) :- + t_hlist( X, S0, SR, SF, G0). +t_hlist([H], S0, SR, ('C'(SR,H,S0)), _) :- !. +t_hlist([H|List], S0, SR, ('C'(SR,H,S1),G0), Goal) :- !, + t_hlist(List, S0, S1, G0, Goal). +t_hlist(T, _, _, _, Goal) :- '$do_error'(type_error(list,T),Goal). @@ -133,77 +133,73 @@ Grammar related built-in predicates: % variables. % Last tells whether we are the ones who should close that chain. % -'$t_body'(Var, filled_in, _, S, S1, phrase(Var,S,S1)) :- +t_body(Var, filled_in, _, S, S1, phrase(Var,S,S1)) :- var(Var), !. -'$t_body'(!, to_fill, last, S, S1, (!, S1 = S)) :- !. -'$t_body'(!, _, _, S, S, !) :- !. -'$t_body'([], to_fill, last, S, S1, S1=S) :- !. -'$t_body'([], _, _, S, S, true) :- !. -'$t_body'(X, FilledIn, Last, S, SR, OS) :- string(X), !, +t_body(!, to_fill, last, S, S1, (!, S1 = S)) :- !. +t_body(!, _, _, S, S, !) :- !. +t_body([], to_fill, last, S, S1, S1=S) :- !. +t_body([], _, _, S, S, true) :- !. +t_body(X, FilledIn, Last, S, SR, OS) :- string(X), !, string_codes( X, Codes), - '$t_body'(Codes, FilledIn, Last, S, SR, OS). -'$t_body'([X], filled_in, _, S, SR, 'C'(S,X,SR)) :- !. -'$t_body'([X|R], filled_in, Last, S, SR, ('C'(S,X,SR1),RB)) :- !, - '$t_body'(R, filled_in, Last, SR1, SR, RB). -'$t_body'({T}, to_fill, last, S, S1, (T, S1=S)) :- !. -'$t_body'({T}, _, _, S, S, T) :- !. -'$t_body'((T,R), ToFill, Last, S, SR, (Tt,Rt)) :- !, - '$t_body'(T, ToFill, not_last, S, SR1, Tt), - '$t_body'(R, ToFill, Last, SR1, SR, Rt). -'$t_body'((T->R), ToFill, Last, S, SR, (Tt->Rt)) :- !, - '$t_body'(T, ToFill, not_last, S, SR1, Tt), - '$t_body'(R, ToFill, Last, SR1, SR, Rt). -'$t_body'(\+T, ToFill, _, S, SR, (Tt->fail ; S=SR)) :- !, - '$t_body'(T, ToFill, not_last, S, _, Tt). -'$t_body'((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !, - '$t_body'(T, _, last, S, SR, Tt), - '$t_body'(R, _, last, S, SR, Rt). -'$t_body'((T|R), _ToFill, _, S, SR, (Tt;Rt)) :- !, - '$t_body'(T, _, last, S, SR, Tt), - '$t_body'(R, _, last, S, SR, Rt). -'$t_body'(M:G, ToFill, Last, S, SR, M:NG) :- !, - '$t_body'(G, ToFill, Last, S, SR, NG). -'$t_body'(T, filled_in, _, S, SR, Tt) :- - '$extend'([S,SR], T, Tt). + t_body(Codes, FilledIn, Last, S, SR, OS). +t_body([X], filled_in, _, S, SR, 'C'(S,X,SR)) :- !. +t_body([X|R], filled_in, Last, S, SR, ('C'(S,X,SR1),RB)) :- !, + t_body(R, filled_in, Last, SR1, SR, RB). +t_body({T}, to_fill, last, S, S1, (T, S1=S)) :- !. +t_body({T}, _, _, S, S, T) :- !. +t_body((T,R), ToFill, Last, S, SR, (Tt,Rt)) :- !, + t_body(T, ToFill, not_last, S, SR1, Tt), + t_body(R, ToFill, Last, SR1, SR, Rt). +t_body((T->R), ToFill, Last, S, SR, (Tt->Rt)) :- !, + t_body(T, ToFill, not_last, S, SR1, Tt), + t_body(R, ToFill, Last, SR1, SR, Rt). +t_body(\+T, ToFill, _, S, SR, (Tt->fail ; S=SR)) :- !, + t_body(T, ToFill, not_last, S, _, Tt). +t_body((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !, + t_body(T, _, last, S, SR, Tt), + t_body(R, _, last, S, SR, Rt). +t_body((T|R), _ToFill, _, S, SR, (Tt;Rt)) :- !, + t_body(T, _, last, S, SR, Tt), + t_body(R, _, last, S, SR, Rt). +t_body(M:G, ToFill, Last, S, SR, M:NG) :- !, + t_body(G, ToFill, Last, S, SR, NG). +t_body(T, filled_in, _, S, SR, Tt) :- + extend([S,SR], T, Tt). -'$extend'(More, OldT, NewT) :- +extend(More, OldT, NewT) :- OldT =.. OldL, lists:append(OldL, More, NewL), NewT =.. NewL. -'$t_tidy'(P,P) :- var(P), !. -'$t_tidy'((P1;P2), (Q1;Q2)) :- !, - '$t_tidy'(P1, Q1), - '$t_tidy'(P2, Q2). -'$t_tidy'((P1->P2), (Q1->Q2)) :- !, - '$t_tidy'(P1, Q1), - '$t_tidy'(P2, Q2). -'$t_tidy'(((P1,P2),P3), Q) :- - '$t_tidy'((P1,(P2,P3)), Q). -'$t_tidy'((true,P1), Q1) :- !, - '$t_tidy'(P1, Q1). -'$t_tidy'((P1,true), Q1) :- !, - '$t_tidy'(P1, Q1). -'$t_tidy'((P1,P2), (Q1,Q2)) :- !, - '$t_tidy'(P1, Q1), - '$t_tidy'(P2, Q2). -'$t_tidy'(A, A). +t_tidy(P,P) :- var(P), !. +t_tidy((P1;P2), (Q1;Q2)) :- !, + t_tidy(P1, Q1), + t_tidy(P2, Q2). +t_tidy((P1->P2), (Q1->Q2)) :- !, + t_tidy(P1, Q1), + t_tidy(P2, Q2). +t_tidy(((P1,P2),P3), Q) :- + t_tidy((P1,(P2,P3)), Q). +t_tidy((true,P1), Q1) :- !, + t_tidy(P1, Q1). +t_tidy((P1,true), Q1) :- !, + t_tidy(P1, Q1). +t_tidy((P1,P2), (Q1,Q2)) :- !, + t_tidy(P1, Q1), + t_tidy(P2, Q2). +t_tidy(A, A). /** @pred `C`( _S1_, _T_, _S2_) This predicate is used by the grammar rules compiler and is defined as `C`([H|T],H,T)`. - - - - */ -'C'([X|S],X,S). +prolog:'C'([X|S],X,S). /** @pred phrase(+ _P_, _L_) @@ -213,10 +209,8 @@ same as `phrase(P,L,[])`. Both this predicate and the previous are used as a convenient way to start execution of grammar rules. - - */ -phrase(PhraseDef, WordList) :- +prolog:phrase(PhraseDef, WordList) :- phrase(PhraseDef, WordList, []). /** @pred phrase(+ _P_, _L_, _R_) @@ -224,45 +218,47 @@ phrase(PhraseDef, WordList) :- This predicate succeeds when the difference list ` _L_- _R_` is a phrase of type _P_. - - */ -phrase(P, S0, S) :- +prolog:phrase(P, S0, S) :- call(P, S0, S). -!(S, S). +prolog:!(S, S). -[](S, S). +prolog:[](S, S). -[](H, T, S0, S) :- lists:append([H|T], S, S0). +prolog:[](H, T, S0, S) :- lists:append([H|T], S, S0). -'.'(H,T, S0, S) :- +prolog:'.'(H,T, S0, S) :- lists:append([H|T], S, S0). -{}(Goal, S0, S) :- +prolog:{}(Goal, S0, S) :- Goal, S0 = S. -','(A,B, S0, S) :- - '$t_body'((A,B), _, last, S0, S, Goal), +prolog:','(A,B, S0, S) :- + t_body((A,B), _, last, S0, S, Goal), '$execute'(Goal). -;(A,B, S0, S) :- - '$t_body'((A;B), _, last, S0, S, Goal), +prolog:;(A,B, S0, S) :- + t_body((A;B), _, last, S0, S, Goal), '$execute'(Goal). -'|'(A,B, S0, S) :- - '$t_body'((A|B), _, last, S0, S, Goal), +prolog:'|'(A,B, S0, S) :- + t_body((A|B), _, last, S0, S, Goal), '$execute'(Goal). -->(A,B, S0, S) :- - '$t_body'((A->B), _, last, S0, S, Goal), +prolog:->(A,B, S0, S) :- + t_body((A->B), _, last, S0, S, Goal), '$execute'(Goal). -\+(A, S0, S) :- - '$t_body'(\+ A, _, last, S0, S, Goal), +prolog:\+(A, S0, S) :- + t_body(\+ A, _, last, S0, S, Goal), '$execute'(Goal). +% stolen from SWI-Prolog + + + /** @} */ From 80faee6824fb813ea3eaf842e9642dd441f30078 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 2 Oct 2014 14:57:50 +0100 Subject: [PATCH 25/25] qload/qsave implementation. --- C/qlyr.c | 81 +++++++++++++--- C/qlyw.c | 24 ++--- pl/consult.yap | 239 +++++++++++++++++++++++++++++++++------------- pl/directives.yap | 9 +- pl/flags.yap | 30 +++++- pl/modules.yap | 3 +- pl/qly.yap | 188 ++++++++++++++++++++++++------------ 7 files changed, 412 insertions(+), 162 deletions(-) diff --git a/C/qlyr.c b/C/qlyr.c index b4c2f7845..2728c543b 100755 --- a/C/qlyr.c +++ b/C/qlyr.c @@ -44,7 +44,8 @@ typedef enum { BAD_ATOM = 8, MISMATCH = 9, INCONSISTENT_CPRED = 10, - BAD_READ = 11 + BAD_READ = 11, + BAD_HEADER = 12 } qlfr_err_t; static char * @@ -77,7 +78,7 @@ static void QLYR_ERROR(qlfr_err_t my_err) { Yap_Error(SAVED_STATE_ERROR,TermNil,"error %s in saved state %s",GLOBAL_RestoreFile, qlyr_error[my_err]); - exit(1); + Yap_exit(1); } static Atom @@ -691,11 +692,56 @@ read_tag(IOSTREAM *stream) return ch; } -static void -read_header(IOSTREAM *stream) +static bool +checkChars(IOSTREAM *stream, char s[]) { - int ch; + int ch, c; + char *p = s; + + while ((ch = *p++)) { + if ((c = read_byte(stream)) != ch ) { + return false; + } + } + return TRUE; +} + +static Atom +get_header(IOSTREAM *stream) +{ + char s[256], *p = s, ch; + Atom at; + + if (!checkChars( stream, "#!/bin/sh\nexec_dir=${YAPBINDIR:-" )) + return NIL; + while ((ch = read_byte(stream)) != '\n'); + if (!checkChars( stream, "exec $exec_dir/yap $0 \"$@\"\nsaved " )) + return NIL; + while ((ch = read_byte(stream)) != ',') + *p++ = ch; + *p++ = '\0'; + at = Yap_LookupAtom( s ); while ((ch = read_byte(stream))); + return at; +} + +static Int +p_get_header( USES_REGS1 ) +{ + IOSTREAM *stream; + Term t1 = Deref(ARG1); + Atom at; + + if (IsVarTerm(t1)) { + Yap_Error(INSTANTIATION_ERROR,t1,"read_program/3"); + return FALSE; + } + if (!(stream = Yap_GetInputStream(AtomOfTerm(t1))) ) { + return FALSE; + } + if ((at = get_header( stream )) == NIL) + return FALSE; + return Yap_unify( ARG2, MkAtomTerm( at ) ); } static void @@ -801,6 +847,7 @@ ReadHash(IOSTREAM *stream) pe = RepPredProp(PredPropByAtomAndMod(a,mod)); } } else { + /* IDB */ if (arity == (UInt)-1) { UInt i = read_UInt(stream); pe = Yap_FindLUIntKey(i); @@ -808,12 +855,18 @@ ReadHash(IOSTREAM *stream) Atom oa = (Atom)read_UInt(stream); Atom a = LookupAtom(oa); pe = RepPredProp(PredPropByAtomAndMod(a,mod)); + pe->PredFlags |= AtomDBPredFlag; } else { Functor of = (Functor)read_UInt(stream); Functor f = LookupFunctor(of); pe = RepPredProp(PredPropByFuncAndMod(f,mod)); } + pe->PredFlags |= LogUpdatePredFlag; pe->ArityOfPE = 3; + if (pe->OpcodeOfPred == UNDEF_OPCODE) { + pe->OpcodeOfPred = Yap_opcode(_op_fail); + pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = FAILCODE; + } } InsertPredEntry(ope, pe); } @@ -959,7 +1012,10 @@ read_pred(IOSTREAM *stream, Term mod) { if (ap->PredFlags & IndexedPredFlag) { Yap_RemoveIndexation(ap); } - + //if (ap->ArityOfPE && ap->ModuleOfPred != IDB_MODULE) + // printf(" %s/%ld\n", NameOfFunctor(ap->FunctorOfPred)->StrOfAE, ap->ArityOfPE); + //else if (ap->ModuleOfPred != IDB_MODULE) + // printf(" %s/%ld\n", ((Atom)(ap->FunctorOfPred))->StrOfAE, ap->ArityOfPE); #if SIZEOF_INT_P==4 fl1 = flags & ((UInt)STATIC_PRED_FLAGS); ap->PredFlags &= ~((UInt)STATIC_PRED_FLAGS); @@ -1013,7 +1069,6 @@ static void read_module(IOSTREAM *stream) { qlf_tag_t x; - read_header(stream); InitHash(); ReadHash(stream); while ((x = read_tag(stream)) == QLY_START_MODULE) { @@ -1070,14 +1125,12 @@ p_read_program( USES_REGS1 ) Yap_Error(INSTANTIATION_ERROR,t1,"read_program/3"); return FALSE; } - if (!IsAtomTerm(t1)) { - Yap_Error(TYPE_ERROR_ATOM,t1,"read_program/3"); - return(FALSE); - } - if (!(stream = Yap_GetInputStream(AtomOfTerm(t1))) ) { + if ((stream = Yap_GetInputStream(AtomOfTerm(t1))) ) { return FALSE; } YAP_Reset( YAP_RESET_FROM_RESTORE ); + if (get_header( stream ) == NIL) + return FALSE; read_module(stream); Sclose( stream ); /* back to the top level we go */ @@ -1092,6 +1145,8 @@ Yap_Restore(char *s, char *lib_dir) if (!stream) return -1; GLOBAL_RestoreFile = s; + if (get_header( stream ) == NIL) + return FALSE; read_module(stream); Sclose( stream ); GLOBAL_RestoreFile = NULL; @@ -1102,7 +1157,9 @@ Yap_Restore(char *s, char *lib_dir) void Yap_InitQLYR(void) { Yap_InitCPred("$qload_module_preds", 1, p_read_module_preds, SyncPredFlag|UserCPredFlag); + Yap_InitCPred("$qload_file_preds", 1, p_read_module_preds, SyncPredFlag|UserCPredFlag); Yap_InitCPred("$qload_program", 1, p_read_program, SyncPredFlag|UserCPredFlag); + Yap_InitCPred("$q_header", 2, p_get_header, SyncPredFlag|UserCPredFlag); if (FALSE) { restore_codes(); } diff --git a/C/qlyw.c b/C/qlyw.c index 16d3c465e..b68175696 100755 --- a/C/qlyw.c +++ b/C/qlyw.c @@ -771,18 +771,18 @@ save_ops(IOSTREAM *stream, Term mod) { } static int -save_header(IOSTREAM *stream) +save_header(IOSTREAM *stream, char type[]) { char msg[256]; - sprintf(msg, "#!/bin/sh\nexec_dir=${YAPBINDIR:-%s}\nexec $exec_dir/yap $0 \"$@\"\n%s", YAP_BINDIR, YAP_FULL_VERSION); + sprintf(msg, "#!/bin/sh\nexec_dir=${YAPBINDIR:-%s}\nexec $exec_dir/yap $0 \"$@\"\n%s %s\n", YAP_BINDIR, type, YAP_FULL_VERSION); return save_bytes(stream, msg, strlen(msg)+1); } static size_t save_module(IOSTREAM *stream, Term mod) { PredEntry *ap = Yap_ModulePred(mod); - save_header( stream ); + save_header( stream, "saved module," ); InitHash(); ModuleAdjust(mod); while (ap) { @@ -813,7 +813,7 @@ save_program(IOSTREAM *stream) { ModEntry *me = CurrentModules; InitHash(); - save_header( stream ); + save_header( stream, "saved state," ); /* should we allow the user to see hidden predicates? */ while (me) { PredEntry *pp; @@ -855,7 +855,7 @@ save_file(IOSTREAM *stream, Atom FileName) { ModEntry *me = CurrentModules; InitHash(); - save_header( stream ); + save_header( stream, "saved file," ); /* should we allow the user to see hidden predicates? */ while (me) { PredEntry *pp; @@ -865,6 +865,7 @@ save_file(IOSTREAM *stream, Atom FileName) { pp = PredEntryAdjust(pp); if (pp && !(pp->PredFlags & (MultiFileFlag|NumberDBPredFlag|AtomDBPredFlag|CPredFlag|AsmPredFlag|UserCPredFlag)) && + pp->ModuleOfPred != IDB_MODULE && pp->src.OwnerFile == FileName) { CHECK(mark_pred(pp)); } @@ -883,8 +884,12 @@ save_file(IOSTREAM *stream, Atom FileName) { CHECK(save_tag(stream, QLY_START_MODULE)); CHECK(save_UInt(stream, (UInt)MkAtomTerm(me->AtomOfME))); while (pp != NULL) { - CHECK(save_tag(stream, QLY_START_PREDICATE)); - CHECK(save_pred(stream, pp)); + if (pp && + !(pp->PredFlags & (MultiFileFlag|NumberDBPredFlag|AtomDBPredFlag|CPredFlag|AsmPredFlag|UserCPredFlag)) && + pp->src.OwnerFile == FileName) { + CHECK(save_tag(stream, QLY_START_PREDICATE)); + CHECK(save_pred(stream, pp)); + } pp = pp->NextPredOfModule; } CHECK(save_tag(stream, QLY_END_PREDICATES)); @@ -966,9 +971,6 @@ p_save_file( USES_REGS1 ) if (!(stream = Yap_GetOutputStream(AtomOfTerm(t1))) ) { return FALSE; } - if (!(stream = Yap_GetOutputStream(AtomOfTerm(t1))) ) { - return FALSE; - } if (IsVarTerm(tfile)) { Yap_Error(INSTANTIATION_ERROR,tfile,"save_file/2"); return FALSE; @@ -984,7 +986,7 @@ void Yap_InitQLY(void) { Yap_InitCPred("$qsave_module_preds", 2, p_save_module_preds, SyncPredFlag|UserCPredFlag); Yap_InitCPred("$qsave_program", 1, p_save_program, SyncPredFlag|UserCPredFlag); - Yap_InitCPred("$qsave_file", 2, p_save_file, SyncPredFlag|UserCPredFlag); + Yap_InitCPred("$qsave_file_preds", 2, p_save_file, SyncPredFlag|UserCPredFlag); if (FALSE) { restore_codes(); } diff --git a/pl/consult.yap b/pl/consult.yap index 3eac4a7ef..9384917fd 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -157,6 +157,23 @@ following flags: If true, raise an error if the file is not a module file. Used by ` use_module/1 and use_module/2. ++ qcompile(+ _Value_) + + SWI-Prolog flag that controls whether loaded files should be also + compiled into `qly` files. The default value is obtained from the flag + `qcompile`: + + `never`, no `qly` file is generated unless the user calls + qsave_file/1 and friends, or sets the qcompile option in + load_files/2; + + `auto`, all files are qcompiled. + + `large`, files above 100KB are qcompiled. + + `part`, not supported in YAP. + + + autoload(+ _Autoload_) SWI-compatible option where if _Autoload_ is `true` undefined @@ -175,7 +192,7 @@ following flags: % expand(true,false) % if(changed,true,not_loaded) => implemented % imports(all,List) => implemented -% qcompile(true,false) +% qcompile() => implemented % silent(true,false) => implemented % stream(Stream) => implemented % consult(consult,reconsult,exo,db) => implemented @@ -191,7 +208,8 @@ load_files(Files,Opts) :- '$lf_option'(expand, 4, false). '$lf_option'(if, 5, true). '$lf_option'(imports, 6, all). -'$lf_option'(qcompile, 7, never). +'$lf_option'(qcompile, 7, Current) :- + '$nb_getval'('$qcompile', Current, Current = never). '$lf_option'(silent, 8, _). '$lf_option'(skip_unix_header, 9, false). '$lf_option'(compilation_mode, 10, source). @@ -315,9 +333,11 @@ load_files(Files,Opts) :- is_list(Val) -> ( ground(Val) -> true ; '$do_error'(instantiation_error,Call) ) ; '$do_error'(domain_error(unimplemented_option,imports(Val)),Call) ). '$process_lf_opt'(qcompile, Val,Call) :- - ( Val == true -> '$do_error'(domain_error(unimplemented_option,expand),Call) ; - Val == false -> true ; - '$do_error'(domain_error(unimplemented_option,expand(Val)),Call) ). + ( Val == part -> '$do_error'(domain_error(unimplemented_option,expand),Call) ; + Val == never -> true ; + Val == auto -> true ; + Val == large -> true ; + '$do_error'(domain_error(unknown_option,qcompile(Val)),Call) ). '$process_lf_opt'(silent, Val, Call) :- ( Val == false -> true ; Val == true -> true ; @@ -327,19 +347,19 @@ load_files(Files,Opts) :- Val == true -> true ; '$do_error'(domain_error(unimplemented_option,skip_unix_header(Val)),Call) ). '$process_lf_opt'(compilation_mode, Val, Call) :- -( Val == source -> true ; - Val == compact -> true ; - Val == assert_all -> true ; - '$do_error'(domain_error(unimplemented_option,compilation_mode(Val)),Call) ). + ( Val == source -> true ; + Val == compact -> true ; + Val == assert_all -> true ; + '$do_error'(domain_error(unimplemented_option,compilation_mode(Val)),Call) ). '$process_lf_opt'(consult, Val , Call) :- - ( Val == reconsult -> true ; - Val == consult -> true ; - Val == exo -> true ; - Val == db -> true ; - '$do_error'(domain_error(unimplemented_option,consult(Val)),Call) ). + ( Val == reconsult -> true ; + Val == consult -> true ; + Val == exo -> true ; + Val == db -> true ; + '$do_error'(domain_error(unimplemented_option,consult(Val)),Call) ). '$process_lf_opt'(reexport, Val , Call) :- ( Val == true -> true ; - Val == false -> true ; + Val == false -> true ; '$do_error'(domain_error(unimplemented_option,reexport(Val)),Call) ). '$process_lf_opt'(must_be_module, Val , Call) :- ( Val == true -> true ; @@ -396,23 +416,54 @@ load_files(Files,Opts) :- b_setval('$source_file', user_input), '$do_lf'(Mod, user_input, user_input, TOpts). '$lf'(File, Mod, Call, TOpts) :- - '$lf_opt'(stream, TOpts, Stream), - b_setval('$source_file', File), - ( var(Stream) -> + '$lf_opt'(stream, TOpts, Stream), + var( Stream ), + H0 is heapused, '$cputime'(T0,_), + % check if there is a qly files + '$absolute_file_name'(File,[access(read),file_type(qly),file_errors(fail),solutions(first),expand(true)],F,load_files(File)), + open( F, read, Stream , [type(binary)] ), + ( '$q_header'( Stream, Type ), + Type == file + -> + time_file64(F, T0F), + '$absolute_file_name'(File,[access(read),file_type(prolog),file_errors(fail),solutions(first),expand(true)],FilePl,load_files(File)), + time_file64(FilePl, T0Fl), + T0F >= T0Fl, + !, + file_directory_name(F, Dir), + working_directory(OldD, Dir), + '$msg_level'( TOpts, Verbosity), + '$lf_opt'(imports, TOpts, ImportList), + '$qload_file'(Stream, Mod, F, FilePl, File, ImportList), + close( Stream ), + H is heapused-H0, '$cputime'(TF,_), T is TF-T0, + '$current_module'(M, Mod), + working_directory( _, OldD), + print_message(Verbosity, loaded( loaded, F, M, T, H)), + '$exec_initialisation_goals' + ; + close( Stream), + fail + ). +'$lf'(File, Mod, Call, TOpts) :- + '$lf_opt'(stream, TOpts, Stream), + b_setval('$source_file', File), + ( var(Stream) -> /* need_to_open_file */ '$full_filename'(File, Y, Call), open(Y, read, Stream) ; - true - ), !, - '$lf_opt'(reexport, TOpts, Reexport), - '$lf_opt'(if, TOpts, If), - ( var(If) -> If = true ; true ), - '$lf_opt'(imports, TOpts, Imports), - '$start_lf'(If, Mod, Stream, TOpts, File, Reexport, Imports), - close(Stream). + stream_property(Stream, file_name(Y)) + ), !, + '$lf_opt'(reexport, TOpts, Reexport), + '$lf_opt'(if, TOpts, If), + ( var(If) -> If = true ; true ), + '$lf_opt'(imports, TOpts, Imports), + '$start_lf'(If, Mod, Stream, TOpts, File, Reexport, Imports), + character_count(Stream, Pos), + close(Stream). '$lf'(X, _, Call, _) :- - '$do_error'(permission_error(input,stream,X),Call). + '$do_error'(permission_error(input,stream,X),Call). '$start_lf'(not_loaded, Mod, Stream, TOpts, UserFile, Reexport,Imports) :- '$file_loaded'(Stream, Mod, Imports, TOpts), !, @@ -587,6 +638,9 @@ db_files(Fs) :- '$lf_opt'('$context_module', TOpts, ContextModule), '$lf_opt'(reexport, TOpts, Reexport), '$msg_level'( TOpts, Verbosity), + '$lf_opt'(qcompile, TOpts, QCompiling), + '$nb_getval'('$qcompile', ContextQCompiling, ContextQCompiling = never), + nb_setval('$qcompile', QCompiling), % format( 'I=~w~n', [Verbosity=UserFile] ), '$lf_opt'(encoding, TOpts, Encoding), '$set_encoding'(Stream, Encoding), @@ -618,18 +672,22 @@ db_files(Fs) :- StartMsg = consulting, EndMsg = consulted ), - print_message(Verbosity, loading(StartMsg, File)), + print_message(Verbosity, loading(StartMsg, UserFile)), '$lf_opt'(skip_unix_header , TOpts, SkipUnixHeader), - ( SkipUnixHeader == true-> + ( SkipUnixHeader == true + -> '$skip_unix_header'(Stream) - ; + ; true - ), - '$loop'(Stream,Reconsult), + ), + '$loop'(Stream,Reconsult), + '$lf_opt'(imports, TOpts, Imports), + '$import_to_current_module'(File, ContextModule, Imports, _, TOpts), + '$end_consult', + '$q_do_save_file'(File, UserFile, ContextModule, TOpts ), H is heapused-H0, '$cputime'(TF,_), T is TF-T0, '$current_module'(Mod, SourceModule), print_message(Verbosity, loaded(EndMsg, File, Mod, T, H)), - '$end_consult', ( Reconsult = reconsult -> '$clear_reconsulting' @@ -646,14 +704,21 @@ db_files(Fs) :- nb_setval('$if_level',OldIfLevel), '$lf_opt'('$use_module', TOpts, UseModule), '$bind_module'(Mod, UseModule), - '$lf_opt'(imports, TOpts, Imports), - '$import_to_current_module'(File, ContextModule, Imports, _, TOpts), '$reexport'( TOpts, ParentF, Reexport, Imports, File ), + nb_setval('$qcompile', ContextQCompiling), ( LC == 0 -> prompt(_,' |: ') ; true), '$exec_initialisation_goals', % format( 'O=~w~n', [Mod=UserFile] ), !. +'$q_do_save_file'(File, UserF, ContextModule, TOpts ) :- + '$lf_opt'(qcompile, TOpts, QComp), + ( QComp == auto ; QComp == large, Pos > 100*1024), + '$absolute_file_name'(UserF,[file_type(qly),solutions(first),expand(true)],F,load_files(File)), + !, + '$qsave_file_'( File, UserF, F ). +'$q_do_save_file'(_File, _, _ContextModule, _TOpts ). + % are we in autoload and autoload_flag is false? '$msg_level'( TOpts, Verbosity) :- '$lf_opt'(autoload, TOpts, AutoLoad), @@ -687,12 +752,11 @@ db_files(Fs) :- '$bind_module'(Mod, use_module(Mod)). '$import_to_current_module'(File, ContextModule, Imports, RemainingImports, TOpts) :- - \+ recorded('$module','$module'(File, _Module, _, _ModExports, _),_), + \+ recorded('$module','$module'(File, _Module, _, _ModExports, _),_), % enable loading C-predicates from a different file recorded( '$load_foreign_done', [File, M0], _), '$import_foreign'(File, M0, ContextModule ), fail. - '$import_to_current_module'(File, ContextModule, Imports, RemainingImports, TOpts) :- recorded('$module','$module'(File, Module, _Source, ModExports, _),_), Module \= ContextModule, !, @@ -836,59 +900,50 @@ source_file(Mod:Pred, FileName) :- Obtain information on what is going on in the compilation process. The following keys are available: ++ directory (prolog_load_context/2 option) - -+ directory - - - -Full name for the directory where YAP is currently consulting the + Full name for the directory where YAP is currently consulting the file. -+ file ++ file (prolog_load_context/2 option) - - -Full name for the file currently being consulted. Notice that included + Full name for the file currently being consulted. Notice that included filed are ignored. -+ module ++ module (prolog_load_context/2 option) - - -Current source module. + Current source module. + `source` (prolog_load_context/2 option) Full name for the file currently being read in, which may be consulted, reconsulted, or included. -+ `stream` ++ `stream` (prolog_load_context/2 option) Stream currently being read in. -+ `term_position` ++ `term_position` (prolog_load_context/2 option) Stream position at the stream currently being read in. For SWI compatibility, it is a term of the form -'$stream_position'(0,Line,0,0,0). +'$stream_position'(0,Line,0,0). - -+ `source_location(? _FileName_, ? _Line_)` ++ `source_location(? _FileName_, ? _Line_)` (prolog_load_context/2 option) SWI-compatible predicate. If the last term has been read from a physical file (i.e., not from the file user or a string), unify File with an absolute path to the file and Line with the line-number in the file. Please use prolog_load_context/2. -+ `source_file(? _File_)` ++ `source_file(? _File_)` (prolog_load_context/2 option) SWI-compatible predicate. True if _File_ is a loaded Prolog source file. -+ `source_file(? _ModuleAndPred_,? _File_)` ++ `source_file(? _ModuleAndPred_,? _File_)` (prolog_load_context/2 option) SWI-compatible predicate. True if the predicate specified by _ModuleAndPred_ was loaded from file _File_, where _File_ is an absolute path name (see `absolute_file_name/2`). +*/ - -@section YAPLibraries Library Predicates +/** @addgroup YAPLibraries Library Predicates Library files reside in the library_directory path (set by the `LIBDIR` variable in the Makefile for YAP). Currently, @@ -919,7 +974,14 @@ prolog_load_context(term_position, Position) :- % if the file exports a module, then we can % be imported from any module. '$file_loaded'(Stream, M, Imports, TOpts) :- - '$file_name'(Stream, F), + '$file_name'(Stream, F0), + ( + atom_concat(Prefix, '.qly', F0 ) + -> + '$absolute_file_name'(Prefix,[access(read),file_type(prolog),file_errors(fail),solutions(first),expand(true)],F,load_files(Prefix)) + ; + F0 = F + ), '$ensure_file_loaded'(F, M, F1), % format( 'IL=~w~n', [(F1:Imports->M)] ), '$import_to_current_module'(F1, M, Imports, _, TOpts). @@ -960,7 +1022,8 @@ prolog_load_context(term_position, Position) :- % inform the file has been loaded and is now available. '$loaded'(Stream, UserFile, M, OldF, Line, Reconsult, F, Dir, Opts) :- '$file_name'(Stream, F0), - ( F0 == user_input, nonvar(UserFile) -> UserFile = F ; F = F0 ), + ( F0 == user_input, nonvar(UserFile) -> UserFile = F + ; F = F0 ), ( F == user_input -> working_directory(Dir,Dir) ; file_directory_name(F, Dir) ), nb_setval('$consulting_file', F ), ( Reconsult \== consult, Reconsult \== not_loaded, Reconsult \== changed, recorded('$lf_loaded','$lf_loaded'(F, _,_),R), erase(R), fail ; var(Reconsult) -> Reconsult = consult ; true ), @@ -1071,6 +1134,52 @@ source_file_property( File0, Prop) :- '$source_file_property'( F, module(M)) :- recorded('$module','$module'(F,M,_,_,_),_). +unload_file( F0 ) :- + absolute_file_name( F0, F1, [expand(true),file_type(prolog)] ), + '$unload_file'( F1, F0 ). + +% eliminate multi-files; +% get rid of file-only predicataes. +'$unload_file'( FileName, _F0 ) :- + '$current_predicate_var'(A,Mod,P). + '$owner_file'(P,Mod,FileName), + \+ '$is_multifile'(P,Mod), + functor( P, Na, Ar), + abolish(Mod:Na/Ar), + fail. +%next multi-file. +'$unload_file'( FileName, _F0 ) :- + recorded('$lf_loaded','$lf_loaded'( F, Age, _), R), + erase(R), + fail. +'$unload_file'( FileName, _F0 ) :- + recorded('$mf','$mf_clause'(FileName,_Name,_Arity,_Module,ClauseRef), R), + erase(R), + erase(ClauseRef), + fail. +'$unload_file'( FileName, _F0 ) :- + recorded('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,FFileName,R), R1), + erase(R1), + erase(R), + fail. +'$unload_file'( FileName, _F0 ) :- + recorded('$multifile_defs','$defined'(FileName,Name,Arity,Mod), R), + erase(R), + fail. +'$unload_file'( FileName, _F0 ) :- + recorded('$multifile_defs','$defined'(FileName,Name,Arity,Mod), R), + erase(R), + fail. +'$unload_file'( FileName, _F0 ) :- + recorded('$module','$module'( FileName, Mod, _SourceF, _, _), R), + erase( R ), + unload_module(Mod), + fail. +'$unload_file'( FileName, _F0 ) :- + recorded('$directive','$d'( FileName, _M:_G, _Mode, _VL, _Pos ), R), + erase(R), + fail. + /** @@ -1370,12 +1479,6 @@ part of the code due to different capabilities. Realise different configuration options for your software. - - - - - - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ :- if(test1). section_1. diff --git a/pl/directives.yap b/pl/directives.yap index 586d09b36..54b11fcd4 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -93,16 +93,17 @@ '$directive'(use_module(_,_,_)). '$directive'(wait(_)). -'$exec_directives'((G1,G2), Mode, M, VL, Pos) :- !, - '$exec_directives'(G1, Mode, M, VL, Pos), - '$exec_directives'(G2, Mode, M, VL, Pos). +'$exec_directives'((G1,G2), Mode, M, VL, Pos) :- + !, + '$exec_directives'(G1, Mode, M, VL, Pos), + '$exec_directives'(G2, Mode, M, VL, Pos). '$exec_directives'(G, Mode, M, VL, Pos) :- '$save_directive'(G, Mode, M, VL, Pos), '$exec_directive'(G, Mode, M, VL, Pos). '$save_directive'(G, Mode, M, VL, Pos) :- prolog_load_context(file, FileName), !, - recorda('$directive', directive(File,M:G, Mode, VL, Pos),_). + recordz('$directive', directive(FileName,M:G, Mode, VL, Pos),_). '$exec_directive'(multifile(D), _, M, _, _) :- '$system_catch'('$multifile'(D, M), M, diff --git a/pl/flags.yap b/pl/flags.yap index 636e7f719..97d26dd45 100644 --- a/pl/flags.yap +++ b/pl/flags.yap @@ -279,6 +279,21 @@ profile_data/3 built-in. SWI-Compatible option, determines prompting for alternatives in the Prolog toplevel. Default is groundness, YAP prompts for alternatives if and only if the query contains variables. The alternative, default in SWI-Prolog is determinism which implies the system prompts for alternatives if the goal succeeded while leaving choicepoints. ++ `qcompile(+{never, auto, large, part}, changeable)` + + SWI-Prolog flag that controls whether loaded files should be also + compiled into qfiles. The default value is `never`. + + `never`, no qcompile file is generated unless the user calls + qsave_file/1 and friends, or sets the qcompile option in + load_files/2; + + `auto`, all files are qcompiled. + + `large`, files above 100KB are qcompiled. + + `part`, not supported in YAP. + + `redefine_warnings ` If _Value_ is unbound, tell whether warnings for procedures defined @@ -873,13 +888,22 @@ yap_flag(chr_toplevel_show_store,X) :- yap_flag(chr_toplevel_show_store,X) :- '$do_error'(domain_error(flag_value,chr_toplevel_show_store+X),yap_flag(chr_toplevel_show_store,X)). +yap_flag(qcompile,X) :- + var(X), !, + '$nb_getval'('$qcompile', X, X=never). +yap_flag(qcompile,X) :- + (X == never ; X == auto ; X == large ; X == part), !, + nb_setval('$qcompile',X). +yap_flag(qcompile,X) :- + '$do_error'(domain_error(flag_value,qcompile+X),yap_flag(qcompile,X)). + yap_flag(source,X) :- var(X), !, source_mode( X, X ). yap_flag(source,X) :- (X == off -> true ; X == on), !, source_mode( _, X ). -yap_flag(chr_toplevel_show_store,X) :- +yap_flag(source,X) :- '$do_error'(domain_error(flag_value,source+X),yap_flag(source,X)). yap_flag(open_expands_filename,Expand) :- @@ -1375,8 +1399,8 @@ create_prolog_flag(Name, Value, Options) :- '$flag_domain_from_value'(_, term). -/** - @pred source_mode(- _O_,+ _N_) +/** + @pred source_mode(- _O_,+ _N_) The state of source mode can either be on or off. When the source mode is on, all clauses are kept both as compiled code and in a "hidden" diff --git a/pl/modules.yap b/pl/modules.yap index b77b23618..24726f3fd 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -705,8 +705,10 @@ expand_goal(G, G). '$do_expand'(G, _, _, _, G) :- var(G), !. '$do_expand'(M:G, _CurMod, SM, HVars, M:GI) :- !, + nonvar(M), '$do_expand'(G, M, SM, HVars, GI). '$do_expand'(G, CurMod, _SM, _HVars, GI) :- + nonvar(G), ( '$pred_exists'(goal_expansion(G,GI), CurMod), call(CurMod:goal_expansion(G, GI)) @@ -1567,7 +1569,6 @@ unload_module(Mod) :- op(X, 0, Mod:Op), fail. unload_module(Mod) :- - fail, current_predicate(Mod:P), abolish(P), fail. diff --git a/pl/qly.yap b/pl/qly.yap index ff37df94d..662050cc7 100755 --- a/pl/qly.yap +++ b/pl/qly.yap @@ -387,46 +387,54 @@ save_program(File, _Goal) :- call(db_import(myddas,Table,Table)), fail. '$myddas_import_all'. - + +qsave_file(F0) :- + ensure_loaded( F0 ), + absolute_file_name( F0, File, [expand(true),file_type(prolog),access(read),file_errors(fail),solutions(first)]), + absolute_file_name( F0, State, [expand(true),file_type(qly)]), + '$qsave_file_'(File, State). + /** @pred qsave_file(+ _File_, +_State_) Saves an image of all the information compiled by the system from file _F_ to _State_. -This includes modules and predicatees eventually including multi-predicates. +This includes modules and predicates eventually including multi-predicates. **/ qsave_file(F0, State) :- - absolute_file_name( F0, File, [expand(true),file_type(qly)]), + ensure_loaded( F0 ), + absolute_file_name( F0, File, [expand(true),file_type(prolog),access(read),file_errors(fail),solutions(first)]), '$qsave_file_'(File, State). -'$qsave_file_'(File, _State) :- - '$recorded'('$directive','$d'( File, M:G, Mode, VL, Pos ), _), - assert(prolog:'$file_property'( directive( M:G, Mode, VL, Pos ) ) ), - '$set_owner_file'(prolog:'$file_property'( _ ), File ), +'$qsave_file_'(File, UserF, _State) :- + ( File == user_input -> Age = 0 ; time_file64(File, Age) ), + assert(user:'$file_property'( '$lf_loaded'( UserF, Age, M) ) ), + '$set_owner_file'( '$file_property'( _ ), user, File ), fail. -'$qsave_file_'(File, _State) :- - recorded('$module', '$module'(F,Mod,Source,Exps,L), _), - '$fetch_parents_module'(Mod, Parents), - '$fetch_imports_module'(Mod, Imps), - assert(prolog:'$file_property'( module( Mod, Exps, L, Parents, Imps ) ) ), - '$set_owner_file'(prolog:'$file_property'( _ ), File ), +'$qsave_file_'(File, UserF, State) :- + recorded('$lf_loaded','$lf_loaded'( File, M, Reconsult, UserFile, OldF, Line, Opts), _), + assert(user:'$file_property'( '$lf_loaded'( UserF, M, Reconsult, UserFile, OldF, Line, Opts) ) ), + '$set_owner_file'( '$file_property'( _ ), user, File ), fail. -'$qsave_file_'(File, _State) :- +'$qsave_file_'(File, _UserF, _State) :- + recorded('$directive',directive( File, M:G, Mode, VL, Pos ), _), + assert(user:'$file_property'( directive( M:G, Mode, VL, Pos ) ) ), + '$set_owner_file'('$file_property'( _ ), user, File ), + fail. +'$qsave_file_'(File, _UserF, _State) :- '$fetch_multi_files_file'(File, MultiFiles), - assert(prolog:'$file_property'( multifile(MultiFiles ) ) ), - '$set_owner_file'(prolog:'$file_property'( _ ), File ), + assert(user:'$file_property'( multifile(MultiFiles ) ) ), + '$set_owner_file'('$file_property'( _ ), user, File ), fail. -'$qsave_file_'( File, State ) :- +'$qsave_file_'( File, _UserF, State ) :- ( is_stream( State ) -> - stream_property(Stream, file_name(File)), - S = Stream, - '$qsave_file_preds'(S, File) + '$qsave_file_preds'(State, File) ; - absolute_file_name( F0, File, [expand(true),file_type(qly)]), open(State, write, S, [type(binary)]), '$qsave_file_preds'(S, File), close(S) - ), abolish(prolog:'$file_property'/2). + ), + abolish(user:'$file_property'/1). '$fetch_multi_files_file'(File, Multi_Files) :- setof(Info, '$fetch_multi_file_module'(File, Info), Multi_Files). @@ -443,7 +451,7 @@ Saves an image of all the information compiled by the systemm on module _F_ to _ **/ qsave_module(Mod, OF) :- - recorded('$module', '$module'(F,Mod,S,Exps,L), _), + recorded('$module', '$module'(F,Mod,Source,Exps,L), _), '$fetch_parents_module'(Mod, Parents), '$fetch_imports_module'(Mod, Imps), '$fetch_multi_files_module'(Mod, MFs), @@ -451,11 +459,11 @@ qsave_module(Mod, OF) :- '$fetch_module_transparents_module'(Mod, ModTransps), '$fetch_term_expansions_module'(Mod, TEs), '$fetch_foreigns_module'(Mod, Foreigns), - asserta(Mod:'@mod_info'(S, Exps, MFs, L, Parents, Imps, Metas, ModTransps, Foreigns, TEs)), + asserta(Mod:'@mod_info'(Source, Exps, MFs, L, Parents, Imps, Metas, ModTransps, Foreigns, TEs)), open(OF, write, S, [type(binary)]), '$qsave_module_preds'(S, Mod), close(S), - abolish(Mod:'@mod_info'/8), + abolish(Mod:'@mod_info'/10), fail. qsave_module(_, _). @@ -512,20 +520,34 @@ qload_module(Mod) :- '$current_module'(_, SourceModule), working_directory(_, OldD). -'$qload_module'(Mod, File, _SourceModule) :- - unload_module( Mod ), - fail. -'$qload_module'(Mod, File, _SourceModule) :- - open(File, read, S, [type(binary)]), - '$qload_module_preds'(S), - close(S), - fail. +'$qload_module'(Mod, S, SourceModule) :- + is_stream( S ), !, + '$q_header'( S, Type ), + stream_property( S, file_name( File )), + ( Type == module -> + '$qload_module'(S , Mod, File, SourceModule) + ; + Type == file -> + '$qload_file'(S, File) + ). '$qload_module'(Mod, File, SourceModule) :- - '$complete_read_module'(Mod, File, SourceModule). + open(File, read, S, [type(binary)]), + '$q_header'( S, Type ), + ( Type == module -> + '$qload_module'(S , Mod, File, SourceModule) + ; + Type == file -> + '$qload_file'(S, File) + ), + close(S). -'$complete_read_module'(Mod, File, CurrentModule) :- +'$qload_module'(_S, Mod, _File, _SourceModule) :- + unload_module( Mod ), fail. +'$qload_module'(S, _Mod, _File, _SourceModule) :- + '$qload_module_preds'(S), fail. +'$qload_module'(_S, Mod, File, SourceModule) :- Mod:'@mod_info'(F, Exps, MFs, Line,Parents, Imps, Metas, ModTransps, Foreigns, TEs), - abolish(Mod:'@mod_info'/9), + abolish(Mod:'@mod_info'/10), recorda('$module', '$module'(File, Mod, F, Exps, Line), _), '$install_parents_module'(Mod, Parents), '$install_imports_module'(Mod, Imps, []), @@ -536,8 +558,8 @@ qload_module(Mod) :- '$install_term_expansions_module'(Mod, TEs), % last, export everything to the host: if the loading crashed you didn't actually do % no evil. - '$convert_for_export'(all, Exps, Mod, CurrentModule, TranslationTab, AllExports0, qload_module), - '$add_to_imports'(TranslationTab, Mod, CurrentModule), % insert ops, at least for now + '$convert_for_export'(all, Exps, Mod, SourceModule, TranslationTab, AllExports0, qload_module), + '$add_to_imports'(TranslationTab, Mod, SourceModule), % insert ops, at least for now sort( AllExports0, AllExports ). '$fetch_imports_module'(Mod, Imports) :- @@ -551,7 +573,7 @@ qload_module(Mod) :- '$fetch_parents_module'(Mod, Parents) :- findall(Parent, prolog:'$parent_module'(Mod,Parent), Parents). -'$fetch_module_transparents_module'(Mod, Module_Transparents) :- +'$fetch_module_transparents_module'(Mod, Mmodule_Transparents) :- findall(Info, '$fetch_module_transparent_module'(Mod, Info), Module_Transparents). % detect an module_transparenterator that is local to the module. @@ -571,9 +593,12 @@ qload_module(Mod) :- % detect an multi_file that is local to the module. '$fetch_multi_file_module'(Mod, '$defined'(FileName,Name,Arity,Mod)) :- recorded('$multifile_defs','$defined'(FileName,Name,Arity,Mod), _). +'$fetch_multi_file_module'(Mod, '$mf_clause'(FileName,_Name,_Arity,_Module,Clause), _) :- + recorded('$mf','$mf_clause'(FileName,_Name,_Arity,_Module,ClauseRef), _), + instance(R, Clause ). -'$fetch_term_expansions_module'(Mod, Term_Expansions) :- - findall(Info, '$fetch_term_expansion_module'(Mod, Info), Term_Expansions). +'$fetch_term_expansions_module'(Mod, TEs) :- + findall(Info, '$fetch_term_expansion_module'(Mod, Info), TEs). % detect an term_expansionerator that is local to the module. '$fetch_term_expansion_module'(Mod, ( user:term_expansion(G, GI) :- Bd )) :- @@ -673,41 +698,78 @@ qload_module(Mod) :- Restores a previously saved state of YAP contaianing a qly file _F_. */ -qload_file(F0) :- - H0 is heapused, '$cputime'(T0,_), - ( is_strean( F0 ) +qload_file( F0 ) :- + ( '$swi_current_prolog_flag'(verbose_load, false) + -> + Verbosity = silent + ; + Verbosity = informational + ), + StartMsg = loading_module, + '$current_module'( SourceModule ), + H0 is heapused, + '$cputime'(T0,_), + ( is_stream( F0 ) -> stream_property(F0, file_name(File) ), - S = F0 + File = FilePl, + S = File ; absolute_file_name( F0, File, [expand(true),file_type(qly)]), + absolute_file_name( F0, FilePl, [expand(true),file_type(prolog)]), + unload_file( FilePl ), open(File, read, S, [type(binary)]) ), - '$qload_file_preds'(S, File), - close(S), - fail - ; - '$complete_read_file'(File). - -'$complete_read_file'(File) :- + print_message(Verbosity, loading(StartMsg, File)), file_directory_name(File, DirName), - working_directory(OldD, Dir), - '$process_directives'( File ), + working_directory(OldD, DirName), + '$q_header'( S, Type ), + ( Type == module -> + '$qload_module'(S , Mod, File, SourceModule) + ; + Type == file -> + '$qload_file'(S, SourceModule, File, FilePl, F0, all) + ), + close(S), working_directory( _, OldD), H is heapused-H0, '$cputime'(TF,_), T is TF-T0, - '$current_module'(Mod, SourceModule), - fail. + '$current_module'(Mod, Mod ), + print_message(Verbosity, loaded(EndMsg, File, Mod, T, H)), + '$exec_initialisation_goals'. -'$process_directives' :- - prolog:'$file_property'( multifile( List ) ), +'$qload_file'(S, SourceModule, F, FilePl, _F0, _ImportList) :- + recorded('$lf_loaded','$lf_loaded'( F, _Age, SourceModule), _), + !. +'$qload_file'(S, _SourceModule, _File, _FilePl, _F0, _ImportList) :- + '$qload_file_preds'(S), + fail. +'$qload_file'(S, SourceModule, F, FilePl, _F0, _ImportList) :- + user:'$file_property'( '$lf_loaded'( _, Age, _ ) ), + recordaifnot('$lf_loaded','$lf_loaded'( F, Age, SourceModule), _), + fail. +'$qload_file'(_S, SourceModule, _File, FilePl, F0, _ImportList) :- + b_setval('$source_file', F0 ), + '$process_directives'( FilePl ), + fail. +'$qload_file'(_S, SourceModule, _File, FilePl, _F0, ImportList) :- + '$import_to_current_module'(FilePl, SourceModule, ImportList, _, _TOpts). + +'$process_directives'( FilePl ) :- + user:'$file_property'( '$lf_loaded'( FilePl, M, Reconsult, UserFile, OldF, Line, Opts) ), + recorda('$lf_loaded','$lf_loaded'( FilePl, M, Reconsult, UserFile, OldF, Line, Opts), _), + fail. +'$process_directives'( _FilePl ) :- + user:'$file_property'( multifile( List ) ), lists:member( Clause, List ), assert( Clause ), fail. -'$process_directives' :- - prolog:'$file_property'( directive( M:G, Mode, VL, Pos ) ), - '$exec_directive'(G, Mode, M, VL, Pos), +'$process_directives'( FilePl ) :- + user:'$file_property'( directive( MG, Mode, VL, Pos ) ), + '$set_source'( FilePl, Pos ), + strip_module(MG, M, G), + '$process_directive'(G, reconsult, M, VL, Pos), fail. -'$process_directives' :- - abolish(prolog:'$file_property'/1). +'$process_directives'( _FilePl ) :- + abolish(user:'$file_property'/1).