paralell improvements

parent df8719d4
......@@ -10,29 +10,29 @@
(<case-lambda>
(() <fail>)
((x) (goal-eval x))
((x y)
(<pand> fail
((fail x y)
(<pand> (</.> (goal-eval fail))
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))))
((x y u)
(<pand> fail
((fail x y u)
(<pand> (</.> (goal-eval fail))
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))
(p3 s3 (gp-make-engine 100) (goal-eval u))))
((x y u v)
(<pand> fail
((fail x y u v)
(<pand> (</.> (goal-eval fail))
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))
(p3 s3 (gp-make-engine 100) (goal-eval u))
(p4 s4 (gp-make-engine 100) (goal-eval v))))
(l
((fail . l)
(let ((l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(if (= n 0)
(cons l u)
(lp (cdr l) (cons (car l) u) (- n 1))))))
(<pand> fail
(p1 s1 (gp-make-engine 100) (<apply> paralell (car l-u)))
(p3 s3 (gp-make-engine 100) (<apply> paralell (cdr l-u))))))))
(<pand> (</.> (goal-eval fail))
(p1 s1 (gp-make-engine 100) (<apply> paralell fail (car l-u)))
(p3 s3 (gp-make-engine 100) (<apply> paralell fail (cdr l-u))))))))
(define pzip
(<case-lambda>
......
......@@ -19,15 +19,24 @@
(<define> (check-bindings check key.vals)
(<recur> lp ((l key.vals))
(if (pair? l)
(let ((x (car l))
(let* ((x (car l))
(k (car x))
(v (cdr x)))
(<if> (<=> k v)
(lp (cdr l))
(check))))))
(check)))
<cc>)))
(<define-guile-log-rule> (<pand> check (v se engine code ...) ...)
(define level 0)
(define next-level 0)
(<define-guile-log-rule> (<pand> check (v l se engine code ...) ...)
(<var> (v ...)
(let ((i level) (n next-level) (l level) ...)
(<dynwind>
(</.> (<cc>))
(</.>
(<code> (set! level i))
(<code> (set! next-level n))))
(<let> ((data (list v ...))
(frame (<newframe>))
(se #f) ...
......@@ -45,21 +54,36 @@
(<with-s> (gp-push-engine frame engine)
(<code> (gp-combine-push data))
(<code> (gp-var-set v (gp-peek-engine) S))
(<dynwind>
(</.>
(<code> (set! level (+ 1 n)))
(<code> (set! next-level (+ 1 n))))
(</.> <cc>))
code ...
(<dynwind>
(</.> (<code> (set! l next-level)))
(</.> (<code> (set! next-level l))))
(<code> (set! se S))
(<code> (gp-pop-engine))))))
...
(<dynwind>
(</.>
(<code> (set! next-level (max l ...)))
(<code> (set! level i)))
(</.> <cc>))
(<code> (gp-combine-engines data))
(let ((s.bindings (gp-combine-state s (list se ...))))
(check-bindings check (cdr s.bindings))
(<with-s> (car s.bindings)
(<with-fail> p <cc>))))))
(<with-fail> p <cc>))))))))
(<define-guile-log-rule> (<pzip> check (v se p code ...) ...)
(<define-guile-log-rule> (<pzip> check (v ll se p code ...) ...)
(<var> (p ...)
(<let*> ((l '())
(<letrec> ((l '())
(pwork
(lambda (q)
(if (pair? l)
......@@ -69,15 +93,16 @@
(q))))
(ccwork
(lambda (s pp cc)
(pwork (lambda () (cc s pp))))))
(<pand> (</.> <fail>)
(v se (gp-make-engine 100) code ... (<set> p P)) ...)
(ccwork)
(let ((pend
(pwork (lambda () (cc s pp)))))
(pend
(lambda ()
(set! l (list (<lookup> p) ...))
(pwork #f))))
(<with-fail> pend <cc>)))))
(<pand> (check pend)
(v ll se (gp-make-engine (+ next-level 1) 100)
code ... (<set> p P)) ...)
(ccwork)
(<with-fail> pend <cc>))))
(<define> (g x n)
......@@ -94,21 +119,23 @@
(if (< i n)
(<or> (<=> x i) (lp (+ i 1))))))
(<define> (idfail fail-all) (fail-all))
(<define> (test1 x y)
(<pzip> (v1 s1 p1 (f x 3)) (v2 s2 p2 (f y 3))))
(<pzip> idfail (v1 l1 s1 p1 (f x 3)) (v2 l2 s2 p2 (f y 3))))
(<define> (test2 x y)
(<pzip> (v1 s1 p1 (<member> 1 x)) (v2 s2 p2 (<member> 2 y))))
(<pzip> idfail (v1 l1 s1 p1 (<member> 1 x)) (v2 l2 s2 p2 (<member> 2 y))))
(<define> (test3 x y)
(<logical++>)
(<pzip> (v1 s1 p1 (g x 10)) (v2 s2 p2 (g y 10)))
(<logical-->))
(<pzip> idfail (v1 l1 s1 p1 (g x 10)) (v2 l2 s2 p2 (g y 10))))
(<define> (test4 x y z w)
(<logical++>)
(<pzip> (v1 s1 p1 (test3 x y)) (v2 s2 p2 (test3 z w)))
(<logical-->))
(<pzip> idfail (v1 l1 s1 p1 (test3 x y)) (v2 l2 s2 p2 (test3 z w))))
......
......@@ -33,46 +33,6 @@ int is_gc_locked();
#define GP_STACKP(scm) (SCM_NIMP(scm) && SCM_SMOB_PREDICATE(gp_stack_type,scm))
struct gp_stack
{
scm_t_bits dynstack_length;
SCM dynstack;
SCM rguards;
SCM handlers;
int id;
int thread_id;
int _logical_;
int _thread_safe_;
int gp_ncs;
SCM *gp_cons_stack;
int gp_nc;
SCM *gp_cstack;
int gp_ns;
SCM *gp_stack;
int gp_nfr;
SCM *gp_frstack;
SCM *gp_cs;
SCM *gp_si;
SCM *gp_ci;
SCM *gp_fr;
SCM *gp_nnc;
SCM *gp_nns;
SCM *gp_nncs;
SCM *gp_nnfr;
int n;
int nrem;
};
#define GP_FRAMESIZE 6
#define CHOICE_BIT (1UL<<60)
#define GP_GET_HANDLERS(fr) ((fr)[-6])
......@@ -181,7 +141,8 @@ inline ulong GP_GET_CONS(SCM *fr)
#define GP_TEST_STACK if(gp->gp_si > gp->gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ns))
#define GET_GP(scm) ((struct gp_stack *) GP_GETREF(scm)[1])
static inline struct gp_stack *get_gp()
inline struct gp_stack *get_gp()
{
SCM gp = scm_fluid_ref(gp_current_stack);
if(GP_STACKP(gp))
......@@ -192,13 +153,22 @@ static inline struct gp_stack *get_gp()
return (struct gp_stack *)0;
}
static inline void init_gp_var(SCM *cand)
inline struct gp_stack *maybe_get_gp()
{
SCM gp = scm_fluid_ref(gp_current_stack);
if(GP_STACKP(gp))
return (struct gp_stack *) GET_GP(gp);
return (struct gp_stack *) 0;
}
inline void init_gp_var(SCM *cand)
{
cand[0] = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
cand[1] = SCM_UNBOUND;
}
static inline SCM *get_gp_var(struct gp_stack *gp)
inline SCM *get_gp_var(struct gp_stack *gp)
{
SCM cand;
GP_TEST_STACK;
......@@ -358,6 +328,7 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, i
gp->thread_id = nthread;
gp->nrem = 0;
gp->n = 0;
gp->id = id;
SCM ret;
......@@ -374,7 +345,7 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, i
for(i = 0; i < gp->gp_ncs && i < 10000; i++)
{
gp->gp_cs[i] = gp_make_cons(gp);
gp->gp_cs[i] = gp_make_cons_id(id);
}
......@@ -385,9 +356,8 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, i
for(i = 0; i < gp->gp_ns && i < 10000; i++)
{
SCM x = gp_make_variable(gp);
SCM x = gp_make_variable_id(id);
gp->gp_si[i] = x;
}
scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack));
......@@ -1252,15 +1222,6 @@ static void gp_module_stack_init()
void gp_init_stacks()
{
gp_stacks = scm_make_fluid_with_default(SCM_EOL);
gp_nil_fr = gp_make_variable();
gp_nil_ci = gp_make_variable();
scm_t_bits tag = GP_MK_FRAME_EQ(gp_type);
SET_FRAME(tag);
GP_GETREF(gp_nil_fr)[0] = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
GP_GETREF(gp_nil_ci)[0] = SCM_PACK(tag);
GP_GETREF(gp_nil_fr)[1] = scm_from_int(GP_FRAMESIZE);
GP_GETREF(gp_nil_ci)[1] = scm_from_int(0);
}
......@@ -1600,7 +1561,6 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
int logical = gp->_logical_;
int level = gp->id;
SCM rguards = gp->rguards;
gp_engine_path = scm_cons(x , gp_engine_path);
......@@ -1612,7 +1572,6 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
gp = get_gp();
gp_clear(SCM_BOOL_F);
gp->_logical_ = logical;
gp->id = level + 1;
gp->rguards = rguards;
if(gp->id > 0)
......@@ -1761,13 +1720,13 @@ SCM folder(SCM key, SCM val, SCM seed, SCM data)
SCM val2 = scm_hash_ref(key, variable_bindings, SCM_BOOL_F);
if(scm_is_true(val))
if(scm_is_true(val2))
{
return seed;
}
else
{
SCM val3 = scm_hash_ref(key, all_variable_bindinges, SCM_BOOL_F);
SCM val3 = scm_hash_ref(key, all_variable_bindings, SCM_BOOL_F);
if(scm_is_true(val3))
{
SCM val4 = scm_hash_ref(key, variable_bindings_found, SCM_BOOL_F);
......@@ -1777,14 +1736,15 @@ SCM folder(SCM key, SCM val, SCM seed, SCM data)
}
else
{
scm_hash_set_x(key, SCM_BOOL_T, variables_bindings_found);
scm_hash_set_x(key, SCM_BOOL_T, variable_bindings_found);
return scm_cons(scm_cons(key,val),
scm_cons(scm_cons(key, val3), seed));
}
}
else
{
scm_hash_set_X(key, val, all_variable_bindings);
scm_hash_set_x(key, val, all_variable_bindings);
return seed;
}
}
}
......@@ -1802,7 +1762,6 @@ SCM level0(SCM data, SCM l, SCM ret)
SCM level1(SCM data, SCM ll, SCM ret)
{
SCM ll = SCM_CAR(l);
SCM l0 = SCM_CAR(data);
for(;SCM_CONSP(ll);ll=SCM_CDR(ll))
{
......@@ -1811,10 +1770,10 @@ SCM level1(SCM data, SCM ll, SCM ret)
{
SCM x = SCM_CAR(ll);
if(vlist_p(x))
ret = vhash_fold_all_exp(data, folder, ret, SCM_CAR(l));
if(SCM_I_VECTOR_P(x))
ret = level0(data, ret);
if(scm_vlist_p(x))
ret = vhash_fold_all_exp(data, folder, ret, x);
if(SCM_I_IS_VECTOR(x))
ret = level0(data, scm_c_vector_ref(ret, 0), ret);
if(SCM_CONSP(x))
ret = folder(SCM_CAR(x), SCM_CDR(x), ret, data);
}
......@@ -1826,13 +1785,13 @@ SCM level1(SCM data, SCM ll, SCM ret)
SCM get_all_conflicting_bindings(SCM l, SCM data)
{
variable_bindings_found = scm_make_hash_table();
all_variable_bindings = scm_make_hash_table();
variable_bindings_found = scm_c_make_hash_table(100);
all_variable_bindings = scm_c_make_hash_table(100);
ret = SCM_EOL;
SCM ret = SCM_EOL;
for(;SCM_CONSP(l);l=SCM_CDR(l))
{
variable_bindings = scm_make_hash_table();
variable_bindings = scm_c_make_hash_table(100);
ret = level1(data, SCM_CAR(l), ret);
}
......@@ -1861,9 +1820,9 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
}
SCM data = scm_cons(l0, scm_from_int(gp->id));
SCM datah = scm_cons(l0, scm_from_int(gp->id));
SCM ret = get_all_conflicting_bindings(ll,data);
SCM ret = get_all_conflicting_bindings(ll,datah);
SCM sout;
......
......@@ -1016,8 +1016,6 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
SCM_EOL);
}
SCM a = scm_reverse(l);
while(nb > na)
{
b = scm_cons(SCM_CAR(path), b);
......
......@@ -23,6 +23,8 @@
#include "libguile/smob.h"
#define VECTOR_HEADER_SIZE 2
static inline struct gp_stack * get_gp();
SCM* gp_lookup_l_1 (SCM *x, SCM l);
SCM* gp_lookup_ll_1(SCM *x, SCM *l);
......@@ -221,7 +223,7 @@ scm_t_bits gp_smob_t;
//#define GP_HASH(x) ((SCM_UNPACK(x) & GPHA) >> H_BITS)
#define GP_ID(x) ((SCM_UNPACK(x) & GPID) >> N_BITS)
#define GP_SETID(x,id) (id << N_BITS | x)
#define GP_SETID(x,id) (((unsigned long) (id)) << N_BITS | (x))
#define GP_COUNT(X) ((scm_t_bits) ((SCM_UNPACK(X) & GPHA) >> H_BITS))
#define GP_SETCOUNT(X,i) (((SCM_UNPACK(X) & (~GPHA)) \
| ((i) << H_BITS)))
......@@ -464,7 +466,7 @@ inline SCM gp_make_s(SCM frci, SCM *l)
return scm_cons(frci,ll);
}
static inline void gp_store_var_2(SCM *id, int simple, struct gp_stack *gp)
inline void gp_store_var_2(SCM *id, int simple, struct gp_stack *gp)
{
GP_TEST_CSTACK;
......@@ -499,23 +501,23 @@ static inline void gp_store_var_2(SCM *id, int simple, struct gp_stack *gp)
gp->gp_ci += 1;
}
static inline void mask_on(int stack_nr, SCM *id, SCM flags)
inline void mask_on(int stack_nr, SCM *id, SCM flags)
{
scm_t_bits nr = ((((scm_t_bits) stack_nr) & 0xffff) << N_BITS);
*id = SCM_PACK((SCM_UNPACK(*id) & GP_CLEAN)| SCM_UNPACK(flags) | nr);
gp_debug2("tag> %x %x\n",SCM_UNPACK(*id),nr);
}
static inline SCM handle(SCM *id, SCM flags, SCM v, SCM l, struct gp_stack *gp, int k, int bang)
inline SCM handle(SCM *id, SCM flags, SCM v, SCM l, struct gp_stack *gp, int k, int bang)
{
if(!GP(GP_UNREF(id)))
scm_misc_error("unify.c: handle"," got non gp variable to set ~a",
scm_list_1(GP_UNREF(id)));
if(gp->_logical_) return logical_add2(GP_UNREF(id),v,l);
if(!bang && gp->_logical_) return logical_add2(GP_UNREF(id),v,l);
if(GP_ID(*id) != gp->id && gp->_thread_safe_)
if(!bang && GP_ID(*id) != gp->id && gp->_thread_safe_)
{
gp_debug0("logical add\n");
return logical_add2(GP_UNREF(id),v,l);
......@@ -557,7 +559,7 @@ static inline SCM handle_l(SCM *id, SCM flags, SCM v, SCM *l, struct gp_stack *g
return SCM_BOOL_T;
}
static inline void handle_force(SCM *id, SCM flags, SCM v)
inline void handle_force(SCM *id, SCM flags, SCM v)
{
if(!GP(GP_UNREF(id)))
......@@ -608,7 +610,7 @@ inline SCM * set_fr_scm(SCM *fr, struct gp_stack *gp)
return f;
}
static inline SCM gp_set_val(SCM *id, SCM v, SCM l, struct gp_stack *gp)
inline SCM gp_set_val(SCM *id, SCM v, SCM l, struct gp_stack *gp)
{
SCM flags;
if(GP_IS_EQ(v))
......@@ -4070,7 +4072,7 @@ SCM gp_copy_vector(SCM **vector, int nvar)
return newvec;
}
SCM inline gp_cons_simple(SCM x, SCM y, SCM s)
static SCM inline gp_cons_simple(SCM x, SCM y, SCM s)
{
struct gp_stack *gp = get_gp();
SCM *f = get_gp_cons_pure(gp);
......@@ -4120,6 +4122,7 @@ typedef struct gp_vm
SCM *fp; /* frame pointer */
} vp_t;
/*
#include "prolog-vm.c"
......@@ -4164,7 +4167,7 @@ return SCM_UNSPECIFIED;
#undef FUNC_NAME
MK_CUSTOM_FKN_MODEL(vm__raw,gp_make_vm_model,"gp-make-vm-model");
*/
SCM_DEFINE(gp_is_deterministic, "gp-deterministic?", 1, 0, 0, (SCM s0)
, "is there no choice points after tag")
......@@ -4251,7 +4254,6 @@ void gp_init()
{
#include "unify.x"
/* stack initializations */
throw_closed_p = scm_make_fluid_with_default(SCM_BOOL_F);
gp_unbound_str = scm_from_locale_string ("<gp>");
......@@ -4286,6 +4288,7 @@ void gp_init()
gp_init_stacks();
init_gpgc();
init_variables();
......@@ -4296,7 +4299,7 @@ void gp_init()
init_matching();
init_prolog_vm();
// init_prolog_vm();
}
......
......@@ -30,8 +30,53 @@
#define i_load Q(9)
#define i_arbr Q(10)
struct gp_stack
{
scm_t_bits dynstack_length;
SCM dynstack;
SCM rguards;
SCM handlers;
int id;
int thread_id;
int _logical_;
int _thread_safe_;
int gp_ncs;
SCM *gp_cons_stack;
int gp_nc;
SCM *gp_cstack;
int gp_ns;
SCM *gp_stack;
int gp_nfr;
SCM *gp_frstack;
SCM *gp_cs;
SCM *gp_si;
SCM *gp_ci;
SCM *gp_fr;
SCM *gp_nnc;
SCM *gp_nns;
SCM *gp_nncs;
SCM *gp_nnfr;
int n;
int nrem;
};
#include "vlist/vlist.h"
#include "indexer/indexer.h"
inline struct gp_stack *maybe_get_gp();
SCM vhash_fold_all_exp(SCM data, SCM (*proc)(SCM, SCM, SCM, SCM)
, SCM ret, SCM vhash);
SCM_API SCM gp_setup_namespace(SCM record, SCM nsfkn);
SCM_API SCM gp_setup_closed(SCM err);
......@@ -180,6 +225,7 @@ SCM_API SCM gp_gp_prune(SCM fr);
SCM_API SCM gp_gp_prune_tail(SCM fr);
SCM_API SCM gp_is_deterministic(SCM s0);
/*
SCM_API SCM gp_setup_prolog_vm_env
(
SCM dls ,
......@@ -217,3 +263,4 @@ SCM_API SCM gp_pack_start
\
scm_misc_error(nmstr,"custom_code is not sat",SCM_EOL); \
}
*/
......@@ -85,12 +85,28 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
SCM gp_make_variable()
{
struct gp_stack *gp = get_gp();
struct gp_stack *gp = maybe_get_gp();
int id = 0;
if(gp)
id = gp->id;
SCM ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell),
gp_variable_gc_kind));
SCM tc = SCM_PACK(GP_SETID(GP_MK_FRAME_UNBD(gp_type), id));
SCM_SET_CELL_WORD_1 (ret, SCM_UNBOUND);
SCM_SET_CELL_WORD_0 (ret, tc);
return ret;
}
SCM gp_make_variable_id(int id)
{
SCM ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell),
gp_variable_gc_kind));
SCM tc = SCM_PACK(GP_SETID(GP_MK_FRAME_UNBD(gp_type), gp->id));
SCM tc = SCM_PACK(GP_SETID(GP_MK_FRAME_UNBD(gp_type), id));
SCM_SET_CELL_WORD_1 (ret, SCM_UNBOUND);
SCM_SET_CELL_WORD_0 (ret, tc);
......@@ -108,6 +124,17 @@ SCM gp_make_cons()
return ret;
}
SCM gp_make_cons_id(int id)
{
SCM ret = PTR2SCM (GC_generic_malloc (3 * sizeof (scm_t_cell),
gp_variable_gc_kind));
SCM tc = SCM_PACK(GP_MK_FRAME_CONS(gp_type));
SCM_SET_CELL_WORD_2 (ret, SCM_UNBOUND);
SCM_SET_CELL_WORD_1 (ret, SCM_UNBOUND);
SCM_SET_CELL_WORD_0 (ret, tc);
return ret;
}
void init_variables()
{
#ifdef HAS_GP_GC
......
......@@ -315,7 +315,8 @@
(define *states* #t)
(define (gp-make-engine n) (gp-make-stack 0 0 n n n n))
(define (gp-make-engine id n)
(gp-make-stack id 0 n n n n))
(define-named-object *gp* (gp-current-stack-ref))
(define root-engine (gp-make-stack 0 0 5000000 5000000 5000000 1000000))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment