Skip to content

GitLab

G
Guile Log
Commit 6794ff0b authored by Stefan Israelsson Tampe's avatar Stefan Israelsson Tampe
Browse files
Options

initial commit for gc of logical variables

parent 29a01677
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1056 additions and 193 deletions
NEWS
View file @ 6794ff0b
......@@ -15,6 +15,10 @@ Version 0.4
* Delimeted continuations
* A catch and throw system
Version 0.4.1
* Fixed some compiler bugs
* Fixed bug in stall
Version 0.5, TODO
* Multi threading capabilities (all)
* Tablating (all)
......@@ -26,4 +30,10 @@ Version 0.5, TODO
* GC of prolog variables (all)
* GC of the (almost) unreachable tail of a stream (all)
* More general functional hashmps (all)
* Attributed variables (all)
\ No newline at end of file
* Attributed variables (all)
* Debugging facilities (prolog)
* Better error messages (prolog)
* Better compilation errors (prolog)
* Faster compilation (prolog)
* Improved matcher (prolog)
* Use guile variables when possible (prolog)
logic/guile-log/code-load.scm
View file @ 6794ff0b
......@@ -39,8 +39,14 @@
gp-handlers-set!
gp-cont-ids-ref
gp-cont-ids-set!
gp-guard-vars
gp-clear-frame
gp-clear-frame!
gp-gc
vlist? vlist-cons vlist-head vlist-tail vlist-null?
vlist-null list->vlist vlist-ref vlist-set!
......
logic/guile-log/guile-prolog/interpreter.scm
View file @ 6794ff0b
......@@ -2,7 +2,8 @@
#:use-module ((logic guile-log) #:select
(<clear> <define> <let> <let*> <=> <lookup> <match> <fail>
<cut> <wrap> <state-ref> <state-set!> <continue>
<code> <scm> <stall> <case-lambda>))
<code> <scm> <stall> <case-lambda> <cc>
<newframe>))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (logic guile-log vlist)
......@@ -264,6 +265,8 @@ HELP FOR PROLOG COMMANDS
(else
l))))
(<define> (wrap_frame) (<let> ((fr (<newframe>))) <cc>))
(<define> (readline_term T O)
(<let*> ((n (fluid-ref -n-))
(pr (if (= n 1) "-? " (format #f "(~a)? " n)))
......@@ -324,6 +327,7 @@ conversation1(X,All,Mute) :-
fluid_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-]),
state_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-],
scm[*user-data*]),
wrap_frame,
conversation2(X,All,Mute).
conversation2(X,All,Mute) :-
......
logic/guile-log/macros.scm
View file @ 6794ff0b
......@@ -8,7 +8,7 @@
#:use-module (srfi srfi-11)
#:use-module (system repl repl)
#:export (<next> <or> <and> <not> <cond> <if>
#:export (<next> <or> <and> <not> <cond> <if> <scm-if>
<with-guile-log> <if-some>
<cc> <fail> <let> <let*> <var> <hvar> </.> <when>
<define> <cut> <pp> <pp-dyn> <dyn> <unify>
......@@ -135,7 +135,7 @@
(define-guile-log <or>
(syntax-rules (****)
((_ meta ) (parse<> meta <fail>))
((_ meta e1) (parse<> meta e1))
((_ (cut s pr cc) . l)
......@@ -145,7 +145,9 @@
(define-syntax or-aux
(syntax-rules ()
((_ meta a)
(parse<> meta a))
(begin
(gp-clear-frame)
(parse<> meta a)))
((_ (cut s p cc) a . as)
(let ((pp (lambda ()
(gp-unwind s)
......@@ -328,9 +330,24 @@
(parse<> meta (<and> (<and!> p) a)))
((_ (cut s p cc) pred a b)
(<or> (cut s p cc)
(<and> (<and!> pred) (<with-fail> p a))
(<let> ((ss S))
(<and> (<and!> pred)
(<with-fail> p
(<code> (gp-clear-frame! ss))
a)))
b))))
(define-guile-log <scm-if>
(syntax-rules ()
((_ (cut s p cc) pred a)
(if pred
(parse<> (cut s p cc) a)
(p)))
((_ (cut s p cc) pred a b)
(if pred
(parse<> (cut s p cc) a)
(parse<> (cut s p cc) b)))))
(define-guile-log <if-some>
(syntax-rules ()
......@@ -470,23 +487,22 @@
;(pp `(parse<> ,@(syntax->datum (syntax l))))
(syntax (parse2<> . l))))))
(define-syntax parse2<>
(lambda (x)
(syntax-case x (if when cond else case)
((_ meta (if p . l) )
#'(<if> meta (<when> p) . l))
#'(<scm-if> meta p . l))
((_ meta (when p . l) )
#'(<if> meta (<when> p) (<and> . l)))
#'(<scm-if> meta p (<and> . l)))
((_ meta (cond (else a ...) . l))
#'(<and> meta a ...))
((_ meta (cond (p a ...) . l))
#'(<if> meta (<when> p)
(<and> a ...)
(cond . l)))
#'(<scm-if> meta p
(<and> a ...)
(cond . l)))
((_ meta (cond))
#'(parse2<> meta <fail>))
......@@ -544,6 +560,7 @@
((_ (name . a) code ...)
(define name
(letrec ((name (lambda (<S> <Cut> <CC> . a)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...)))))
(set-procedure-property! name 'module get-module)
......@@ -569,6 +586,7 @@
(syntax-rules ()
((_ as code ...)
(lambda (<S> <Cut> <CC> . as)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...))))))
......@@ -577,6 +595,7 @@
((_ (as code ...) ...)
(case-lambda
((<S> <Cut> <CC> . as)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...)))
...))))
......@@ -589,32 +608,31 @@
(car #'((a ...) ...))))
((r ...) (map (lambda x #'_) (car #'((a ...) ...)))))
#'(lambda (<S> <Cut> <CC> b ...)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<match> (#:mode +) (b ...)
(a ... code) ... (r ... (<cut> <fail>))))))))))
(define-syntax-rule (map2 f (a ...) (b ...))
(map (lambda (a ...) (map (lambda (a ...) f) a ...)) b ...))
(define-syntax-rule (map2 f (a ...) b)
(map (lambda (a ...) (map (lambda (a ...) f) a ...)) b))
(define-syntax <<case-lambda>>
(lambda (x)
(syntax-case x ()
((_ ((a ... code) ...) ...)
((_ ((as ... codes) ... (a ... code)) ...)
(with-syntax ((((b ...) ...)
(map2 (datum->syntax #'q (gensym "q"))
(l)
((map car #'(((a ...) ...) ...)))))
(((r ...) ...)
(map2 #'_ (l)
((map car #'(((a ...) ...) ...))))))
#'((a ...) ...))))
#'(case-lambda
((<S> <Cut> <CC> b ...)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<match> (#:mode +) (b ...)
(a ... code)
(as ... codes)
...
(r ... (<cut> <fail>)))))
(a ... (<cut> code)))))
...))))))
......@@ -623,6 +641,7 @@
(syntax-rules ()
((_ (cut s p cc) n ((w v) ...) code ...)
(letrec ((n (lambda (ss pp cccc w ...)
(gp-gc)
(<with-guile-log> (cut ss pp cccc)
(<and> code ...)))))
(parse<> (cut s p cc)
......
logic/guile-log/prolog/goal-transformers.scm
View file @ 6794ff0b
......@@ -245,7 +245,7 @@
(<define> (<iss> x y)
(<let> ((x (<lookup> x)))
(if (number? x)
(if (number? x)
(if (number? y)
(if (inexact? x)
(if (inexact? y)
(when (my-equal? x y))
......
logic/guile-log/src/state.c
View file @ 6794ff0b
This diff is collapsed.
logic/guile-log/src/unify-undo-redo.c
View file @ 6794ff0b
This diff is collapsed.
logic/guile-log/src/unify.c
View file @ 6794ff0b
......@@ -23,6 +23,7 @@
#include "unify.h"
#define VECTOR_HEADER_SIZE 2
#define GP_USE_GC_MOCK 1
SCM tester = SCM_BOOL_F;
......@@ -30,6 +31,12 @@ SCM inline get_cs(SCM v);
SCM gp_current_stack = SCM_BOOL_F;
int do_gp_mark = 1;
#define gp_store 1
#define gp_redo 2
#define gp_redo_tag 10
#define gp_save_tag 14
SCM_DEFINE(gp_get_current_stack, "gp-current-stack-ref", 0, 0, 0, (),
"takes cdr a prolog pair or scheme pair")
......@@ -143,7 +150,8 @@ scm_t_bits gp_smob_t;
#define GPQ_EQ B(0xa0000)
#define GPI_SCM_M B(0x400000)
#define GPI_GL_M B(0x1800000)
#define GPI_SCM_C B(0x800000)
#define GPI_SCM_Q B(0x1000000)
#define GPM_PTR B(0x0ffff)
#define GPM_CONS B(0x1ffff)
......@@ -204,6 +212,18 @@ scm_t_bits gp_smob_t;
#define N_BITS 22
#define H_BITS 36
#define GP_GC_MARK(x) (x = ((x) | GPI_SCM_M))
#define GP_GC_ISMARKED(x) ((x) & GPI_SCM_M)
#define GP_GC_CLEAR(x) ((x) = (x) & ~(GPI_SCM_M))
#define GP_GC_CAND(x) (x = ((x) | GPI_SCM_C))
#define GP_GC_ISCAND(x) ((x) & GPI_SCM_C)
#define GP_GC_CLEARCAND(x) ((x) = (x) & ~(GPI_SCM_C))
#define GP_GC_QAND(x) (x = ((x) | GPI_SCM_Q))
#define GP_GC_ISQAND(x) ((x) & GPI_SCM_Q)
#define GP_GC_CLEARQAND(x) ((x) = (x) & ~(GPI_SCM_Q))
inline static SCM GP_IT(SCM* id)
{
return GP_UNREF(id);
......@@ -233,19 +253,9 @@ SCM gp_unwind_fluid;
SCM gp_cons_sym;
SCM gp_cons_str;
#include "state.c"
static inline struct gp_stack *get_gp()
{
SCM gp = scm_fluid_ref(gp_current_stack);
if(GP_STACKP(gp))
return (struct gp_stack *) SCM_SMOB_DATA(gp);
scm_misc_error("get_gp","could not find stacks",SCM_EOL);
return (struct gp_stack *)0;
}
static inline SCM gp_make_vector(int n, struct gp_stack *gp)
{
......@@ -370,14 +380,13 @@ inline SCM gp_make_s(SCM ci, SCM *l)
return scm_cons(ci,ll);
}
#define GP_TEST_CSTACK if(gp->gp_ci > gp->gp_nnc) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_nc))
static inline void gp_store_var_2(SCM *id, int simple, struct gp_stack *gp)
{
GP_TEST_CSTACK;
if(!GP(GP_UNREF(id)))
scm_misc_error("gp_store_var_2"," got non gp variable to set",SCM_EOL);
scm_misc_error("gp_store_var_2"," got non gp variable to set ~a",
scm_list_1(GP_UNREF(id)));
if(GP_UNBOUND(id))
{
......@@ -406,7 +415,8 @@ static inline SCM handle(SCM *id, SCM flags, SCM v, SCM l, struct gp_stack *gp,
{
if(!GP(GP_UNREF(id)))
scm_misc_error("unify.c: handle"," got non gp variable to set",SCM_EOL);
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);
......@@ -439,7 +449,8 @@ static inline SCM handle_l(SCM *id, SCM flags, SCM v, SCM *l, struct gp_stack *g
{
if(!GP(GP_UNREF(id)))
scm_misc_error("unify.c: handle"," got non gp variable to set",SCM_EOL);
scm_misc_error("unify.c: handle_l"," got non gp variable to set ~a",
scm_list_1(GP_UNREF(id)));
if(gp->_logical_) return logical_add2_l(GP_UNREF(id),v,l);
......@@ -472,12 +483,29 @@ static inline void handle_force(SCM *id, SCM flags, SCM v)
{
if(!GP(GP_UNREF(id)))
scm_misc_error("unify.c: handle"," got non gp variable to set",SCM_EOL);
scm_misc_error("unify.c: handle force"," got non gp variable to set ~a",
scm_list_1(GP_UNREF(id)));
int i = SCM_UNPACK(id[0]) >> N_BITS;
mask_on(i, id, flags);
*(id + 1) = v;
}
SCM * set_ci(SCM *ci, struct gp_stack *gp)
{
SCM *f = get_gp_var(gp);
SCM flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
handle_force(f, flags, SCM_PACK(((ci - gp->gp_cstack)<<2) + 2));
ci[-2] = PTR2NUM(f);
return f;
}
static inline void set_ci_f(SCM *ci, SCM f, struct gp_stack *gp)
{
ci[-2] = PTR2NUM(GP_GETREF(f));
GP_GETREF(f)[1] = SCM_PACK(((ci - gp->gp_cstack) << 2) | 1);
}
static inline SCM gp_set_val(SCM *id, SCM v, SCM l, struct gp_stack *gp)
{
......@@ -751,99 +779,88 @@ static inline SCM * gp_lookup_ll(SCM *id, SCM *l)
//#define DB(X) X
static inline SCM gp_newframe(SCM s)
{
SCM *ci,l;
SCM l;
struct gp_stack *gp = get_gp();
SCM tag;
if(SCM_CONSP(s))
{
tag = SCM_CAR(s);
ci = NUM2PTR(tag);
l = SCM_CDR(s);
}
else
{
s = SCM_PACK(0);
ci = gp->gp_ci;
l = SCM_EOL;
}
{
SCM ha = ci[-4];
scm_t_bits dyn_n = SCM_UNPACK(ci[-3]);
SCM *si = NUM2PTR (ci[-2]);
SCM v = get_cs (ci[-1]);
SCM *cs = NUM2PTR(v);
gp_debug0("check\n");
DB(if(cs < gp->gp_cons_stack || cs > gp->gp_cons_stack + 1000)
{
printf("er %x %x\n",cs - gp->gp_cons_stack,
cs - gp->gp_stack);
scm_misc_error("newframe","cs got wrong value ~a",
scm_list_1(ci[-1]));
});
check_cs(cs,gp,"newframe 0");
gp_debug3("work (%p %p %p)\n",
gp->gp_ci - ci,
gp->gp_si - si,
gp->gp_cs - cs);
if(si == gp->gp_si &&
cs == gp->gp_cs &&
dyn_n == gp->dynstack_length &&
ha == gp->handlers &&
ci == gp->gp_ci)
{
gp_debug0("return same\n");
if(s)
return s;
else
return scm_cons(PTR2NUM(gp->gp_ci), l);
}
{
SCM ret;
gp_debug0("newframe\n");
GP_TEST_CSTACK;
gp->gp_ci += 4;
SCM ret;
SCM *f;
SCM *ci;
gp_debug0("newframe\n");
GP_TEST_CSTACK;
SCM cons = PTR2NUM(gp->gp_ci);
ci = gp->gp_ci + 4;
l = scm_is_false(l) ? SCM_EOL : l;
ret = scm_cons(cons, l);
gp->gp_ci[-4] = gp->handlers;
gp->gp_ci[-3] = SCM_PACK (gp->dynstack_length);
gp->gp_ci[-2] = PTR2NUM (gp->gp_si);
gp->gp_ci[-1] = PTR2NUM (gp->gp_cs);
gp_debug0("return\n");
return ret;
}
}
l = scm_is_false(l) ? SCM_EOL : l;
ci[-4] = gp->handlers;
ci[-3] = SCM_PACK (gp->dynstack_length);
f = set_ci(ci,gp);
set_cs_si(ci, gp);
ret = scm_cons(GP_UNREF(f), l);
gp->gp_ci = ci;
gp_debug0("return\n");
return ret;
}
}
//#define DB(X)
#define GP_TEST_STACK if(gp->gp_si > gp->gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ns))
int gp_gc_counter = 0;
static inline SCM* gp_mk_var(SCM s)
{
SCM *ret;
struct gp_stack *gp = get_gp();
int n = gp->gp_nns - gp->gp_si;
gp_debug0("got a gp");
if(gp->_logical_) return GP_GETREF(make_logical());
GP_TEST_STACK;
gp_debug1("test stack handled! %x\n",gp->gp_si);
ret = gp->gp_si;
gp->gp_si += 2;
gp_gc_counter++;
if(n > 10000)
{
gp_gc_counter++;
}
else if (n > 1000)
{
if(gp_gc_counter >= 10000)
{
scm_gc();
gp_gc_counter = 0;
}
}
else if (n > 100)
{
if(gp_gc_counter >= 1000)
{
scm_gc();
gp_gc_counter = 0;
}
}
else
{
if(gp_gc_counter >= 100)
{
scm_gc();
gp_gc_counter = 0;
}
}
ret = get_gp_var(gp);
mask_on(gp->id,ret,SCM_PACK(GP_MK_FRAME_UNBD(gp_type)));
*(ret + 1) = SCM_UNBOUND;
......@@ -861,7 +878,7 @@ static inline SCM gp_mk_cons(SCM s)
struct gp_stack *gp;
gp = get_gp();
if(gp->_logical_) return scm_cons(make_logical(),make_logical());
if(1 || gp->_logical_) return scm_cons(make_logical(),make_logical());
......@@ -2369,7 +2386,7 @@ SCM_DEFINE(gp_cons_bang, "gp-cons!", 3, 0, 0, (SCM car, SCM cdr, SCM s),
SCM *id;
struct gp_stack *gp = get_gp();
if(gp->_logical_) return scm_cons(car,cdr);
if(1 || gp->_logical_) return scm_cons(car,cdr);
gp_debus0("gp-cons>\n");
cons = GP_GETREF(gp_mk_cons(s));
......@@ -2865,10 +2882,28 @@ SCM gp_save_mark_sym;
#include "unify-undo-redo.c"
#ifndef GP_USE_GC_MOCK
static size_t gp_type_free(SCM obj)
{
SCM *v = GP_GETREF(obj);
scm_t_bits head = SCM_UNPACK(v[0]);
if(!GP_GC_ISQAND(head))
{
scm_gc_free(GP_GETREF(obj), 2*sizeof(SCM), "gp-variable-free");
}
return 0;
}
#endif
static SCM gp_type_mark(SCM obj)
{
SCM *v = GP_GETREF(obj);
scm_gc_mark(v[1]);
scm_t_bits head = SCM_UNPACK(v[0]);
GP_GC_MARK(head);
v[0] = SCM_PACK(head);
return SCM_BOOL_T;
}
......@@ -2905,7 +2940,7 @@ SCM_DEFINE(gp_make_fluid, "gp-make-var", 0, 0, 0, (),
int old = gp->_logical_;
gp->_logical_ = 0;
SCM_NEWSMOB(ret,GP_MK_FRAME_UNBD(gp_type),(void *)0);
ret = gp_make_variable();
gp_set_unbound_bang(GP_GETREF(ret), l, gp);
gp->_logical_ = old;
return ret;
......@@ -3127,6 +3162,7 @@ int _gp_pair_star(SCM **spp, int nargs, SCM *cl, SCM *max)
//#include "util.c"
#include "indexer/indexer.c"
void gp_init()
{
#include "unify.x"
......@@ -3145,15 +3181,23 @@ void gp_init()
gp_cons_sym = scm_string_to_symbol (gp_cons_str);
gp_type = scm_make_smob_type("unify-variable",0);
scm_set_smob_print(gp_type,gp_printer);
scm_set_smob_mark(gp_type,gp_type_mark);
scm_set_smob_print(gp_type, gp_printer);
scm_set_smob_mark(gp_type, gp_type_mark);
#ifndef GP_USE_GC_MOCK
scm_set_smob_free(gp_type, gp_type_free);
#endif
gp_current_stack = scm_make_fluid();
gp_module_stack_init();
vlist_init();
gp_init_stacks();
init_gpgc();
init_variables();
}
......
logic/guile-log/src/unify.h
View file @ 6794ff0b
......@@ -114,3 +114,8 @@ SCM_API SCM gp_cont_ids_ref();
SCM_API SCM gp_cont_ids_set_x(SCM h);
SCM_API SCM gp_guard_vars(SCM s);
SCM_API SCM gp_clear_frame();
SCM_API SCM gp_clear_frame_x(SCM s);
SCM_API SCM gp_gc();
logic/guile-log/src/variable.c 0 → 100644
View file @ 6794ff0b
#include <gc.h>
#include <gc/gc_mark.h>
/*
We need a special variable
*/
#ifdef GP_USE_GC_MOCK
static int gp_variable_gc_kind;
static struct GC_ms_entry *
gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
struct GC_ms_entry *mark_stack_limit, GC_word env)
{
register SCM cell;
cell = PTR2SCM (addr);
if (SCM_TYP7 (cell) != scm_tc7_smob)
/* It is likely that the GC passed us a pointer to a free-list element
which we must ignore (see warning in `gc/gc_mark.h'). */
return mark_stack_ptr;
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
mark_stack_ptr,
mark_stack_limit, NULL);
return mark_stack_ptr;
}
#endif
SCM gp_make_variable()
{
#ifdef GP_USE_GC_MOCK
SCM ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell),
gp_variable_gc_kind));
SCM tc = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
SCM_SET_CELL_WORD_1 (ret, SCM_UNBOUND);
SCM_SET_CELL_WORD_0 (ret, tc);
return ret;
#else
SCM ret = scm_new_smob(gp_type, (scm_t_bits)0);
SCM *v = GP_GETREF(ret);
v[0] = SCM_PACK(GP_MK_FRAME_UNBD(gp_type) | GPI_SCM_Q);
v[1] = SCM_UNBOUND;
return ret;
#endif
}
void
gp_gc_mark_no_touch (SCM o)
{
#ifdef GP_USE_GC_MOCK
if (SCM_NIMP (o))