Commit b2ec7413 authored by Stefan Israelsson Tampe's avatar Stefan Israelsson Tampe
parents 89c0d31b 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)
......@@ -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!
......
......@@ -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) :-
......
......@@ -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)
......
......@@ -262,7 +262,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))
......
This diff is collapsed.
This diff is collapsed.
......@@ -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();
}
......
......@@ -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();
#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))
{
void *mark_stack_ptr, *mark_stack_limit;
mark_stack_ptr = NULL;
mark_stack_limit = NULL;
GC_MARK_AND_PUSH_NO_TOUCH
(SCM2PTR (o),
mark_stack_ptr, mark_stack_limit,
NULL);
}
#else
{ // Mark the byte to prvent gc in the finalizer
SCM *v = GP_GETREF(o);
scm_t_bits head = SCM_UNPACK(v[0]);
GP_GC_QAND(head);
v[0] = SCM_PACK(head);
}
#endif
}
void init_variables()
{
#ifdef GP_USE_GC_MOCK
gp_variable_gc_kind
= GC_new_kind_adv (GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (gp_mark_variable), 0),
0,1,(GC_word) GPI_SCM_M);
#endif
}
......@@ -54,11 +54,16 @@
gp-undo-safe-variable-guard
gp-abort gp-prompt
gp-clear-frame
gp-clear-frame!
gp-handlers-ref
gp-handlers-set!
gp-cont-ids-ref
gp-cont-ids-set!)
gp-cont-ids-set!
gp-gc)
......@@ -126,9 +131,8 @@