refaktoring the persistance code

parent d32af400
......@@ -20,8 +20,7 @@ PSSOURCES = \
ice-9/vset.scm \
logic/guile-log/scmspace.scm \
logic/guile-log/fstream.scm \
logic/guile-log/primitive.scm \
logic/guile-log/persistance.scm \
logic/guile-log/persistance-guile-log.scm \
logic/guile-log/guile-log-pre.scm \
logic/guile-log/ck.scm \
logic/guile-log/vlist.scm \
......
......@@ -48,10 +48,9 @@ For correct garbage collection, engines and fibers you need
furthermore check out 'configure --help' to find out how
to configure in this feature (Experimental)
If you want to hack the prolog VM (it is written in compiled scheme)
you need
https://gitlab.com/clambda/clambda
You need install guile-persist
https://gitlab.com/tampe/guile-persist
You need autotools, texinfo, gcc, make, guile >= 2.0
Either do a system install:
......
(define-module (persist persistance-guile-log)
#:use-module (persist persistance)
#:use-module (persist primitive)
#:use-module (logic guile-log procedure-properties)
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log vlist)
#:re-export (make-persister
load-persists
save-persists
persist-set!
persist-ref
make-shallow
associate-getter-setter
name-object
name-object-deep
define-named-object
define-shallow-object
define-fluid-object
pcopyable?
deep-pcopyable?
pcopy
deep-pcopy
repersist
))
(set! (@@ (persist persistance) set-object-property!)
set-object-property!)
(set! (@@ (persist persistance) object-property)
object-property)
(set! (@@ (persist persistance) set-procedure-property!)
set-procedure-property!)
(set! (@@ (persist persistance) procedure-property)
procedure-property)
(set! (@@ (persist persistance) procedure-name)
procedure-name)
(set! (@@ (persist persistance) gp-cons?)
(@@ (logic guile-log code-load) gp-cons?))
(set! (@@ (persist persistance) gp-cons-1)
(@@ (logic guile-log code-load) gp-cons-ref-1))
(set! (@@ (persist persistance) gp-cons-2)
(@@ (logic guile-log code-load) gp-cons-ref-2))
(set! (@@ (persist persistance) gp-make-pure-cons)
(@@ (logic guile-log code-load) gp-make-pure-cons))
(set! (@@ (persist persistance) gp-cons-set-1!)
(@@ (logic guile-log code-load) gp-cons-set-1!))
(set! (@@ (persist persistance) gp-cons-set-2!)
(@@ (logic guile-log code-load) gp-cons-set-2!))
(set! (@@ (persist persistance) curstack?)
(lambda (x)
(eq? x (fluid-ref
((@@ (logic guile-log code-load)
gp-current-stack-ref))))))
(set! (@@ (persist persistance) get-curstack)
(lambda ()
(fluid-ref ((@@ (logic guile-log code-load) gp-current-stack-ref)))))
(set! (@@ (persist persistance) vlist-null* ) vlist-null )
(set! (@@ (persist persistance) gp-make-var ) gp-make-var )
(set! (@@ (persist persistance) gp-clobber-var) gp-clobber-var)
(set! (@@ (persist persistance) gp-get-id-data) gp-get-id-data)
(set! (@@ (persist persistance) gp? ) gp? )
(primitive-module '(logic guile-log code-load))
(define-module (logic guile-log primitive)
#:use-module (logic guile-log procedure-properties)
#:use-module (system vm program)
#:use-module (logic guile-log code-load)
#:export (get-primitive primitive?))
(define m (make-hash-table))
(define (primitive? x)
(and (procedure? x)
(program? x)
(primitive-code? (program-code x))))
(define f
(lambda (k v)
(if (and (variable? v) (variable-bound? v) (primitive? (variable-ref v)))
(hash-set! m k (variable-ref v)))))
(module-for-each f (resolve-module '(guile)))
(module-for-each f (resolve-module '(logic guile-log code-load)))
(define (get-primitive x)
(define nm (if (procedure? x) (procedure-name x) x))
(hash-ref m nm #f))
......@@ -15,3 +15,72 @@ SCM_DEFINE(gp_find_elf_relative_adress, "gp-bv-address", 1, 0, 0,
return scm_from_uintptr_t(ref);
}
#undef FUNC_NAME
SCM_DEFINE(gp_make_null_procedure, "gp-make-null-procedure", 2, 0, 0, (SCM n, SCM def),
"reuse a variable and make a new one")
#define FUNC_NAME s_gp_make_null_procedure
{
int i,nfree;
scm_t_bits *x;
uintptr_t a = scm_to_uintptr_t(def);
nfree = scm_to_int(n);
x = (scm_t_bits *) scm_gc_malloc (sizeof(SCM)*(nfree + 2), "program");
x[0] = scm_tc7_program;
x[1] = a;
for(i = 0; i < nfree; i++)
{
x[2+i] = SCM_UNPACK(SCM_UNSPECIFIED);
}
return GP_UNREF(x);
}
#undef FUNC_NAME
SCM_DEFINE(gp_fill_null_procedure, "gp-fill-null-procedure", 3, 0, 0, (SCM proc, SCM addr, SCM l),
"reuse a variable and make a new one")
#define FUNC_NAME s_gp_fill_null_procedure
{
uintptr_t a = scm_to_uintptr_t(addr);
int i = 0;
SCM_SET_CELL_WORD_1 (proc, a);
for(;SCM_CONSP(l);l = SCM_CDR(l),i++)
{
SCM_PROGRAM_FREE_VARIABLE_SET(proc,i,SCM_CAR(l));
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_make_struct, "gp-make-struct", 2, 0, 0,
(SCM vtable_data, SCM n),
"")
#define FUNC_NAME s_gp_make_struct
{
SCM ret;
int i,nn = scm_to_int(n);
ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, scm_to_int(n) + 2);
SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
for(i = 0; i < nn; i++)
GP_GETREF(ret)[i+2] = SCM_UNSPECIFIED;
return ret;
}
#undef FUNC_NAME
SCM_DEFINE(gp_set_struct, "gp-set-struct", 2, 0, 0,
(SCM s, SCM l),
"")
#define FUNC_NAME s_gp_set_struct
{
int i;
SCM *v = GP_GETREF(s);
SCM vtable = SCM_CAR(l);
l = SCM_CDR(l);
v[0] = SCM_PACK(((scm_t_bits) SCM_STRUCT_DATA(vtable)) | scm_tc3_struct);
v = GP_GETREF(v[1]);
for(i=0;SCM_CONSP(l);l=SCM_CDR(l),i++)
{
v[i] = SCM_CAR(l);
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......@@ -3753,36 +3753,6 @@ SCM_DEFINE(gp_get_id_data, "gp-get-id-data", 1, 0, 0, (SCM x),
}
#undef FUNC_NAME
SCM_DEFINE(gp_code_to_int, "code-to-int", 1, 0, 0, (SCM x),
"get the gp id tag")
#define FUNC_NAME s_gp_code_to_int
{
scm_t_bits y = SCM_UNPACK(x);
if((y & 7) == 4)
return SCM_PACK((y&~7) | 2);
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE(gp_int_to_code, "int-to-code", 1, 0, 0, (SCM x),
"get the gp id tag")
#define FUNC_NAME s_gp_int_to_code
{
scm_t_bits y = SCM_UNPACK(x);
return SCM_PACK((y&~7) | 4);
}
#undef FUNC_NAME
SCM_DEFINE(gp_get_var_var, "gp-get-var-var", 1, 0, 0, (SCM x),
"take out the gp var data part")
#define FUNC_NAME s_gp_get_var_var
{
SCM *ref = GP_GETREF(x);
return ref[1];
}
#undef FUNC_NAME
SCM_DEFINE(gp_clobber_var, "gp-clobber-var", 3, 0, 0, (SCM var, SCM id, SCM val),
"reuse a variable and make a new one")
#define FUNC_NAME s_gp_clobber_var
......@@ -3794,73 +3764,6 @@ SCM_DEFINE(gp_clobber_var, "gp-clobber-var", 3, 0, 0, (SCM var, SCM id, SCM val
}
#undef FUNC_NAME
SCM_DEFINE(gp_make_null_procedure, "gp-make-null-procedure", 2, 0, 0, (SCM n, SCM def),
"reuse a variable and make a new one")
#define FUNC_NAME s_gp_make_null_procedure
{
int i,nfree;
scm_t_bits *x;
uintptr_t a = scm_to_uintptr_t(def);
nfree = scm_to_int(n);
x = (scm_t_bits *) scm_gc_malloc (sizeof(SCM)*(nfree + 2), "program");
x[0] = scm_tc7_program;
x[1] = a;
for(i = 0; i < nfree; i++)
{
x[2+i] = SCM_UNPACK(SCM_UNSPECIFIED);
}
return GP_UNREF(x);
}
#undef FUNC_NAME
SCM_DEFINE(gp_fill_null_procedure, "gp-fill-null-procedure", 3, 0, 0, (SCM proc, SCM addr, SCM l),
"reuse a variable and make a new one")
#define FUNC_NAME s_gp_fill_null_procedure
{
uintptr_t a = scm_to_uintptr_t(addr);
int i = 0;
SCM_SET_CELL_WORD_1 (proc, a);
for(;SCM_CONSP(l);l = SCM_CDR(l),i++)
{
SCM_PROGRAM_FREE_VARIABLE_SET(proc,i,SCM_CAR(l));
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_make_struct, "gp-make-struct", 2, 0, 0,
(SCM vtable_data, SCM n),
"")
#define FUNC_NAME s_gp_make_struct
{
SCM ret;
int i,nn = scm_to_int(n);
ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, scm_to_int(n) + 2);
SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
for(i = 0; i < nn; i++)
GP_GETREF(ret)[i+2] = SCM_UNSPECIFIED;
return ret;
}
#undef FUNC_NAME
#define FUNC_NAME s_gp_set_struct
SCM_DEFINE(gp_set_struct, "gp-set-struct", 2, 0, 0,
(SCM s, SCM l),
"")
{
int i;
SCM *v = GP_GETREF(s);
SCM vtable = SCM_CAR(l);
l = SCM_CDR(l);
v[0] = SCM_PACK(((scm_t_bits) SCM_STRUCT_DATA(vtable)) | scm_tc3_struct);
v = GP_GETREF(v[1]);
for(i=0;SCM_CONSP(l);l=SCM_CDR(l),i++)
{
v[i] = SCM_CAR(l);
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#define PROGRAM_CODE(x) ((scm_t_uint32 *) (((SCM*) (x))[1]))
SCM_DEFINE(gp_custom_fkn, "gp-custom-fkn",3,0,0,
......@@ -3887,7 +3790,6 @@ SCM_DEFINE(gp_custom_fkn, "gp-custom-fkn",3,0,0,
#include "indexer/indexer.c"
#include "attributed.c"
#include "matcher.c"
#include "guile-2.2.c"
#define SCM_ASYNC_TICK_WITH_GUARD_CODE(thr, pre, post) \
do \
......
......@@ -200,15 +200,8 @@ SCM_API SCM gp_get_taglist();
SCM_API SCM gp_match(SCM e, SCM run, SCM s);
SCM_API SCM gp_set_type_attribute(SCM x);
SCM_API SCM gp_find_elf_relative_adress(SCM ip);
SCM_API SCM gp_get_id_data(SCM x);
SCM_API SCM gp_get_var_var(SCM x);
SCM_API SCM gp_clobber_var(SCM var, SCM id, SCM val);
SCM_API SCM gp_int_to_code(SCM x);
SCM_API SCM gp_code_to_int(SCM x);
SCM_API SCM gp_make_null_procedure(SCM n, SCM def);
SCM_API SCM gp_fill_null_procedure(SCM proc, SCM addr, SCM l);
SCM_API SCM gp_combine_pop();
SCM_API SCM gp_combine_push(SCM r);
......@@ -222,8 +215,6 @@ SCM_API SCM gp_peek_engine();
SCM_API SCM gp_combine_engines(SCM l);
SCM_API SCM gp_combine_state(SCM s, SCM l);
SCM_API SCM gp_get_current_engine_path();
SCM_API SCM gp_set_struct(SCM a, SCM b);
SCM_API SCM gp_make_struct(SCM a, SCM b);
SCM_API SCM gp_custom_fkn(SCM custom_vm_fkn, SCM a, SCM b);
SCM_API SCM gp_gp_prune(SCM fr);
SCM_API SCM gp_gp_prune_tail(SCM fr);
......
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