fast version of matching function implemented

parent ce02352a
......@@ -22,6 +22,7 @@ PSSOURCES = \
logic/guile-log/vlist.scm \
logic/guile-log/indexer.scm \
logic/guile-log/umatch.scm \
logic/guile-log/match.scm \
logic/guile-log/attributed.scm \
logic/guile-log/macros.scm \
logic/guile-log/undovar.scm \
......
......@@ -119,6 +119,9 @@
multibute
gp-make-ephermal-pair
gp-get-taglist
gp-match
))
;; Tos silence the compiler, those are fetched from the .so file
......
......@@ -1295,6 +1295,16 @@ add/run * vlist *
((_ pat)
(<lambda-dyn> pat <cc>))))
(define-syntax <lambda-dyn-meta>
(syntax-rules ()
((_ pat)
(list (lambda () (mk-varpat pat))
(lambda () "true")))
((_ pat y)
(list (lambda () (mk-varpat pat))
(lambda () y)))))
(define-syntax <lambda-dyn-extended>
(lambda (x)
(syntax-case x ()
......
......@@ -137,6 +137,7 @@
catch throw call unify_with_occurs_check copy_term findall bagof
setof var atom integer float atomic compound nonvar number
dynamic multifile discontiguous
assertaf assertzf
asserta assertz clause retract abolish current_predicate
op current_op set_prolog_flag
repeat once
......
(define-module (logic guile-log match)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log umatch)
#:export (compile-match mockalambda))
(define compile-prolog #f)
(define-syntax-rule (aif (it) p a b) (let ((it p)) (if it a b)))
(define taglist (reverse (gp-get-taglist)))
(define pp #f)
(define* (tr x #:optional (m #f))
(define-syntax-rule (tr-it x (i j nm) ...)
(cond
((eq? x 'nm) (if (or (not m) (eq? m '+))
(list-ref taglist i)
(list-ref taglist j)))
...))
(if pp
x
(tr-it x
(0 0 match_var)
(1 1 match_evar)
(2 18 unify_scm)
(3 19 unify_internal)
(4 20 unify_external)
(5 6 cons_plus)
(6 6 cons_minus)
(7 8 vector_plus)
(8 8 vector_minus)
(9 9 pop_vec)
(10 10 pop)
(11 11 and_tag)
(12 12 or_tag)
(13 13 next_or)
(14 14 last_or)
(15 15 fail)
(16 16 pop_frame)
(17 17 leave)
(18 18 unify_scm_minus)
(19 19 unify_internal_minus)
(20 20 unify_external_minus))))
(define table #f)
(define (term-variables s x pred)
(define vars (make-hash-table))
(let lp ((x x))
(match x
(#(xx ...)
(lp xx))
((a . b)
(lp a)
(lp b))
(a
(if (and (gp-var? a s) (pred a))
(aif (it) (hashq-ref vars a #f)
(hashq-set! vars a (+ 1 it))
(hashq-set! vars a 0))))))
vars)
(define external-vars (map (lambda (x) (make-fluid #f)) (iota 256)))
(define and-tag 'and)
(define or-tag 'or)
(define not-tag 'not)
(define fail-tag 'fail)
(define (m x) (lambda (y) (eq? x y)))
(define-syntax-rule (mk n)
(lambda ()
(let ((r n))
(set! n (+ n 1))
r)))
(define (compile-match s exp res)
(define labi 0)
(define labels (mk labi))
(define ie 0)
(define ne (mk ie))
(define ii 0)
(define ni (mk ii))
(define touch (make-hash-table))
(define extvars (make-hash-table))
(define (diff x y)
(define res '())
(hash-for-each
(lambda (k v)
(if (not (hashq-ref y k #f))
(set! res (cons k res))))
x)
res)
(define true (lambda x #t))
(let ((iv (term-variables s exp true))
(ev (term-variables s res true)))
(define epred
(lambda (x)
(hashq-ref ev x #f)))
(define (tr-orvars x)
(let lp ((x (append x (list (tr 'leave)))))
(match x
(((and a (? (lambda (x) (member x '(or-tag next-or)))))
x l . u)
`(,a ,x ,(map (lambda (x) (hashq-ref touch x #f)) l) ,@(lp u)))
(((and a (? (lambda (x) (member x '(last-or)))))
l . u)
`(,a ,(map (lambda (x) (hashq-ref touch x #f)) l) ,@(lp u)))
((x . l)
(cons x (lp l)))
(x x))))
(define (tr-gotos x)
(define map (make-hash-table))
(cons
(list->vector
(let ((n (length x)))
(reverse
(let lp ((x (reverse x))
(i 0))
(match x
(((#:label . x) . u)
(hashq-set! map x i)
(lp u i))
(((#:goto . x) . l)
(cons (- n (hashq-ref map x 10000000) 2) (lp l (+ i 1))))
((x . l)
(cons x (lp l (+ i 1))))
(x x))))))
extvars))
(tr-gotos
(tr-orvars
(let lp ((exp exp) (mode '+))
(match exp
(((? (m or-tag)))
(tr 'fail))
(((? (m or-tag)) x)
(lp x mode))
(((? (m or-tag)) x . l)
(let* ((lb (labels))
(all (term-variables s exp epred))
(this (term-variables s x epred))
(other (diff all this)))
`(,(tr 'or-tag) ,(cons #:goto lb) ,other ,@(lp x mode)
,(cons #:label lb)
,@(let lp2 ((l l))
(match l
((x)
`(,(tr 'last-or) ,(diff all
(term-variables s x epred))
,@(lp x mode)))
((x . l)
(let ((lb (labels))
(other (diff all (term-variables s x epred))))
`(,(tr 'next-or) ,(cons #:goto lb) ,other
,@(lp x mode)
,(cons #:label lb) ,@(lp2 l)))))))))
((? (m fail-tag))
(list (tr 'fail)))
((? (m '_))
(list #f))
(((? (m not-tag)) x)
(lp `((,or-tag (,and-tag ,x ,fail-tag) _)) mode))
(((? (m and-tag)) x)
(lp x mode))
(((? (m and-tag)) x . l)
`(,(tr 'and) ,@(lp x mode)
,@(let lp2 ((l l))
(match l
((x)
`(,(tr 'redo) ,@(lp x mode) ,(tr 'pop)))
((x . l)
`(,(tr 'redo) ,@(lp x mode) ,@(lp2 l)))))))
(((? (m '+)) x)
(lp x '+))
(((? (m '-)) x)
(lp x '-))
((x . l)
`(,(tr 'cons_plus mode) ,@(lp x mode) ,(tr 'pop) ,@(lp l mode)))
(#(x ...)
`(,(tr 'vector_plus mode) ,(length x)
,@(match x
(()
'())
((x)
(lp x mode))
((x . l)
`(,@(lp x mode) ,(tr 'next-vec)
,@(let lp2 ((l l))
(match l
((x)
`(,@(lp x mode) ,(tr 'pop-vec)))
((x . l)
`(,@(lp x mode) ,(tr 'next-vec) ,@(lp2 l))))))))))
(x
(if (gp-var? x s)
(if (hashq-ref ev x #f)
(aif (r) (hashq-ref touch x #f)
(list (tr 'unify_external mode) r)
(let ((next-e (ne)))
(hashq-set! touch x next-e)
(hashq-set! extvars x next-e)
(list (tr 'match_evar)
(list-ref external-vars next-e))))
(aif (r) (hashq-ref touch x #f)
(list (tr 'unify_internal mode) r)
(let ((next-i (ni)))
(hashq-set! touch x next-i)
(list (tr 'match_var) next-i))))
(list (tr 'unify_scm mode) x)))))))))
(define mu (make-fluid '()))
(define (mockalambda_ s pat code)
(define (get-extvars table)
(define temp '())
(hash-for-each
(lambda x (set! temp (cons x temp)))
table)
temp)
(set! pp #t)
(pretty-print `(compiled ,(compile-match s pat code)))
(set! pp #f)
(let* ((comp.table (compile-match s pat code))
(comp (pk 'comp (car comp.table)))
(table (cdr comp.table))
(extvars (get-extvars table))
(vars (map car extvars))
(ivars (map cadr extvars))
(fvars (map (lambda (i) (list-ref external-vars i))
ivars))
(n (let lp ((l ivars) (i -1))
(if (pair? l)
(lp (cdr l) (max (car l) i))
i)))
(oth (compile-prolog s pat code #f (list #t #t)))
(lam (compile-prolog s vars code #f (list #t #f))))
(list
(car oth)
(case (length fvars)
((0)
(lambda (s p cc cut x)
(let ((s (gp-match x comp s)))
(if s
(lam s p cc cut)
(p)))))
((1)
(lambda (s p cc cut x)
(let ((s (gp-match x comp s)))
(if s
(let* ((f (car fvars))
(v (fluid-ref f)))
(fluid-set! f #f)
(lam s p cc cut v))
(p)))))
((2)
(lambda (s p cc cut x)
(let ((s (gp-match x comp s)))
(if s
(let* ((f1 (car fvars))
(v1 (fluid-ref f1))
(f2 (cadr fvars))
(v2 (fluid-ref f2)))
(fluid-set! f1 #f)
(fluid-set! f2 #f)
(lam s p cc cut v1 v2))
(p)))))
(else
(lambda (s p cc cut x)
(let ((s (gp-match x comp s)))
(if s
(let ((vs (map (lambda (x) (fluid-ref x)) fvars)))
(for-each (lambda (x) (fluid-set! x #f)) fvars)
(apply lam s p cc cut vs))
(p))))))
(cadr oth))))
(define (mockalambda s pat code)
(mockalambda_ s pat code))
......@@ -64,10 +64,19 @@
(define is-compile-all (make-fluid #f))
(define (compile-prolog s a f source? extention?)
(define meta-only? (and (pair? extention?)
(eq? (car extention?) #t)
(cadr extention?)))
(define fast-compile?
(and (pair? extention?)
(eq? (car extention?) #t)
(not (cadr extention?))))
(define in-house (make-hash-table))
(define ex-house (make-hash-table))
(define fkns (make-hash-table))
(define (add-fkn x)
(let ((r (hashq-ref fkns x #f)))
(unless r
......@@ -621,25 +630,47 @@
(with-fluids ((*current-language* (lookup-language 'scheme)))
(set! src
(lambda (lam u)
(if (pair? extention?)
(pp 'comp
(cond
(meta-only?
(pp 'comp
`(,@lam (,@u ,@vfkn ,@varq ,@ovarq)
(,(G let) ,(map (lambda (w v) (list w v))
(append vars ovars)
(append varq ovarq))
((@@ (logic guile-log functional-database)
<lambda-dyn-extended>) ,aa
(,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff)))))
(pp 'comp
<lambda-dyn-meta>) ,aa
,(list (G cons) `,aaa `,fff))))))
(fast-compile?
(pp 'comp
`(,@lam (,@u ,@vfkn ,@varq ,@ovarq)
(,(G let) ,(map (lambda (w v) (list w v))
(append vars ovars)
(append varq ovarq))
((@ (logic guile-log) <lambda> ) (cut ,@aa)
((@ (logic guile-log) <with-cut>) cut
(,(GL <var>) ,vars ,ff)))))))
((and (pair? extention?))
(pp 'comp
`(,@lam (,@u ,@vfkn ,@varq ,@ovarq)
(,(G let) ,(map (lambda (w v) (list w v))
(append vars ovars)
(append varq ovarq))
((@@ (logic guile-log functional-database)
<lambda-dyn-extended>) ,aa
(,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff))))))
(else
(pp 'comp
`(,@lam (,@u ,@vfkn ,@varq ,@ovarq)
(,(G let) ,(map (lambda (w v) (list w v))
(append vars ovars)
(append varq ovarq))
((@@ (logic guile-log functional-database)
<lambda-dyn>) ,aa
(,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff))))))))
,(list (G cons) `,aaa `,fff)))))))))
(if (not source?) (compile (src (list (G lambda)) '())
#:env (current-module)) #f)))
(define (lamlam lam)
......@@ -669,3 +700,4 @@
(append vars ovars)))))))
(set! (@@ (logic guile-log match) compile-prolog) compile-prolog)
......@@ -2,6 +2,7 @@
#:use-module (logic guile-log prolog compile)
#:use-module (logic guile-log prolog directives)
#:use-module (logic guile-log functional-database)
#:use-module (logic guile-log match)
#:use-module (logic guile-log prolog goal)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log prolog error)
......@@ -12,7 +13,8 @@
#:use-module (logic guile-log)
#:use-module (ice-9 match)
#:re-export (define-dynamic define-dynamic! define-dynamic-f)
#:export (asserta assertz clause retract abolish current_predicate
#:export (asserta assertz assertaf assertzf
clause retract abolish current_predicate
asserta-source assertz-source))
(define once-f #f)
(define (maybe-call x)
......@@ -20,6 +22,78 @@
(vector (list call x))
x))
(define-syntax-rule (mk-assert++ asserta <push-dynamic>)
(<define> (asserta Arg ext)
(<<match>> (#:mode - #:name asserta) (Arg)
((? <var?>)
(instantiation_error))
(#((":-" Head Body ))
(<recur> lp ((Head Head))
(<<match>> (#:mode - #:name subassert) (Head)
((? <var?>)
(instantiation_error))
(#((F . A))
(<cut>
(<recur> lp2 ((F (<lookup> F)))
(if (not (dynamic? F))
(if (procedure? F)
(if (object-property F 'prolog-symbol)
(lp2 (F))
(permission_error modify static_procedure
(vector
(list divide
F
(length (<scm> A))))))
(type_error callable F))
(<push-dynamic> (<lookup> F)
(catch #t
(lambda ()
(mockalambda (<scm> S)
(<scm> A)
(<scm> Body)))
(lambda x
(format
#t "PROLOG HOT COMPILE ERROR:~%~a~%~%" x)
(type_error S P CC callable Body))))))))
(F
(if (procedure? (<lookup> F))
(lp (vector (list F)))
(type_error callable Head))))))
(#((F . A))
(<cut>
(<recur> lp ((F (<lookup> F)))
(if (not (dynamic? F))
(if (procedure? F)
(if (object-property F 'prolog-symbol)
(lp (F))
(permission_error modify static_procedure
(vector
(list divide
F
(length (<scm> A))))))
(type_error callable F))
(<and>
(<push-dynamic> (<lookup> F)
(catch #t
(lambda ()
(mockalambda (<scm> S) (<scm> A) true))
(lambda x
(format #t "PROLOG HOT COMPILE ERROR:~%~a~%~%" x)
(type_error S P CC callable true)))))))))
(F
(if (procedure? (<lookup> F))
(asserta (vector (list F)) ext)
(type_error callable Arg))))))
(mk-assert++ asserta+_ <push-dynamic>)
(mk-assert++ assertz+_ <append-dynamic>)
(define-syntax-rule (mk-assert+ asserta <push-dynamic>)
(<define> (asserta Arg ext)
(<<match>> (#:mode - #:name asserta) (Arg)
......@@ -182,6 +256,12 @@
(<define> (assertz x . l)
(assertz_ x (if (null? l) #f l)))
(<define> (assertaf x . l)
(asserta+_ x (if (null? l) #f l)))
(<define> (assertzf x . l)
(assertz+_ x (if (null? l) #f l)))
(<define> (clause Head Body)
(<let> ((Head (<lookup> Head)))
(cond
......
/*
TODO: make use of vlists to enable scalable solutions to these algorithms
TODO: enable cp to use attribute hooks
TODO: use a list of preserved variables in cp
TODO: enable functions
TODO: enable vectors
TODO: enable closures
TODO: enable namespaces
*/
SCM canon_var;
SCM ref_var;
SCM tag_var;
SCM canon(SCM e, SCM s)
{
SCM map = scm_c_make_hash_table(32);
SCM before = scm_c_make_hash_table(256);
SCM stack_cdr[100], stack_car[100], conses[100];
int ncons = 0;
int mode = 0, modes[100], nmode = 0, ncar = 0, ncdr = 0;
scm_t_bits n = 2, ntag = 2;
retry:
e = gp_gp_lookup(e,s);
if(scm_is_true(gp_pair(e, s)))
{
SCM r = scm_hashq_ref(before, e, SCM_BOOL_F);
if(scm_is_true(r))
{
if(scm_is_eq(r, SCM_BOOL_T))
{
r = SCM_PACK(ntag);
scm_hashq_set_x(before, e, r);
ntag += 4;
}
e = scm_cons(ref_var, r);
goto next;
}
else
scm_hashq_set_x(before, e, SCM_BOOL_T);
conses[ncons++] = e;
modes[nmode++] = mode;
stack_cdr[ncdr++] = gp_gp_cdr(e,s);
mode = 0;
e = gp_car(e,s);
goto retry;
}
if(scm_is_true(gp_varp(e,s)))
{
SCM r = scm_hashq_ref(map, e, SCM_BOOL_F);
if(scm_is_true(r))
{
e = r;
}
else
{
SCM r = scm_cons(canon_var, SCM_PACK(n));
n = n + 4;
scm_hashq_set_x(map, e, r);
e = r;
}
}
next:
if(mode == 0)
{
if(ncdr == 0)
return e;
SCM newdata = stack_new[ncdr-1];
SCM olddata = stack_old[ncdr-1];
if(SCM_CONSP(newdata))
{
SCM_SETCAR(newdata,e);
e = SCM_CDR(olddata);
mode = 1;
goto retry;
}
if(SCM_VECTORP(newdata))
{
int i = scm_c_vector_length(newdata);
if(i == 1)
{
scm_c_vector_set_x(newdata, 0, e);
ncdr--;
e = newdata;
mode = modes[ncdr];
goto next;
}
else
{
scm_c_vector_set_x(newdata, 0, e);
mode = 1;
e = scm_c_vector_ref(olddata, 1,);
goto retry;
}
}
}
if(mode == 1)
{
SCM r = conses[--ncons];
r = scm_hashq_ref(before, r, SCM_BOOL_F);
e = scm_cons(stack_car[--ncar], e);
if(scm_is_true(r) && !scm_is_eq(r, SCM_BOOL_T))
e = scm_cons(tag_var, scm_cons(r, e));
mode = modes[--nmode];
goto next;
}
return SCM_BOOL_F;
}
//#define DB(X) X
SCM uncanon(SCM e, SCM s)
{
SCM refs[100], variables[100], varref[100], stack_car[100], stack_cdr[100];
int nvar = 0, nv=0, nmode=0, modes[100], mode=0, ncdr=0, ncar=0;
retry:
e = gp_gp_lookup(e , s);
gp_format1("e: ~a~%", e);
if(SCM_CONSP(e))
{
SCM tag = SCM_CAR(e);
gp_format2("tag: ~a ~a~%", tag, ref_var);
gp_debug1("%d\n",scm_is_eq(tag, ref_var));
if(scm_is_eq(tag, tag_var))
{
SCM cdr = SCM_CDR(e);
int i = SCM_UNPACK(SCM_CAR(cdr)) >> 2;
refs[i] = scm_make_variable(SCM_BOOL_F);
variables[nvar++] = refs[i];
e = SCM_CDR(cdr);
}
else if(scm_is_eq(tag, ref_var))
{
int i = SCM_UNPACK(SCM_CDR(e)) >> 2;
gp_debug0("ref\n");
e = refs[i];
goto next;
}
else if(scm_is_eq(tag, canon_var))
{
int i = SCM_UNPACK(SCM_CDR(e)) >> 2;
if(i >= nv)
{
int j;
for(j = nv; j <= i; j++)
varref[j] = SCM_BOOL_F;
nv = i + 1;
}
if(scm_is_false(varref[i]))
varref[i] = gp_make_variable();
gp_format2("varref[~a] = ~a~%",SCM_CDR(e),varref[i]);
e = varref[i];
goto next;
}
else