clpfd compiles and loades with the new fastmatch lambdas

parent 5987916d
...@@ -22,6 +22,7 @@ PSSOURCES = \ ...@@ -22,6 +22,7 @@ PSSOURCES = \
logic/guile-log/vlist.scm \ logic/guile-log/vlist.scm \
logic/guile-log/indexer.scm \ logic/guile-log/indexer.scm \
logic/guile-log/umatch.scm \ logic/guile-log/umatch.scm \
logic/guile-log/repr.scm \
logic/guile-log/match.scm \ logic/guile-log/match.scm \
logic/guile-log/attributed.scm \ logic/guile-log/attributed.scm \
logic/guile-log/macros.scm \ logic/guile-log/macros.scm \
......
...@@ -204,7 +204,7 @@ mkdyn([[X|L]],(make_dynamic(X),U)) :- mkdyn(L,U). ...@@ -204,7 +204,7 @@ mkdyn([[X|L]],(make_dynamic(X),U)) :- mkdyn(L,U).
all((X : Y) :- Z) :- !,fail. all((X : Y) :- Z) :- !,fail.
all((H :- X)) :- !, all((H :- X)) :- !,
assertz(H :- call(X)), assertzf(H :- call(X)),
fail. fail.
all((:- Head)) :- !, all((:- Head)) :- !,
...@@ -222,7 +222,7 @@ all(Head) :- ...@@ -222,7 +222,7 @@ all(Head) :-
( (
Head =.. [F|L] -> Head =.. [F|L] ->
( (
assertz(Head) assertzf(Head)
) ; ) ;
atom(Head) -> assertz(Head) atom(Head) -> assertz(Head)
), ),
......
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (logic guile-log umatch) #:use-module (logic guile-log umatch)
#:use-module (logic guile-log repr)
#:export (compile-match mockalambda)) #:export (compile-match mockalambda))
(define compile-prolog #f) (define compile-prolog #f)
...@@ -78,7 +79,7 @@ ...@@ -78,7 +79,7 @@
(set! n (+ n 1)) (set! n (+ n 1))
r))) r)))
(define (compile-match s exp res) (define (compile-match source? s exp res)
(define labi 0) (define labi 0)
(define labels (mk labi)) (define labels (mk labi))
...@@ -103,7 +104,7 @@ ...@@ -103,7 +104,7 @@
res) res)
(define true (lambda x #t)) (define true (lambda x #t))
(let ((iv (term-variables s exp true)) (let ((iv (term-variables s exp true))
(ev (term-variables s res true))) (ev (term-variables s res true)))
...@@ -111,18 +112,30 @@ ...@@ -111,18 +112,30 @@
(lambda (x) (lambda (x)
(hashq-ref ev x #f))) (hashq-ref ev x #f)))
(define (tr-orvars x) (define (tr-orvars stx? x)
(define (trv x)
(if stx?
#`(list-ref external-vars #,x)
(list-ref external-vars x)))
(let lp ((x (append x (list (tr 'leave))))) (let lp ((x (append x (list (tr 'leave)))))
(match x (match x
(((and a (? (lambda (x) (member x '(or-tag next-or))))) (((and a (? (lambda (x) (member x '(or-tag next-or)))))
x l . u) x l . u)
`(,a ,x ,(map (lambda (x) (hashq-ref touch x #f)) l) ,@(lp u))) `(,a ,x ,(map (lambda (x) (trv (hashq-ref touch x #f)))
(((and a (? (lambda (x) (member x '(last-or))))) l)
l . u) ,@(lp u)))
`(,a ,(map (lambda (x) (hashq-ref touch x #f)) l) ,@(lp u)))
((x . l) (((and a (? (lambda (x) (member x '(last-or)))))
(cons x (lp l))) l . u)
(x x)))) `(,a ,(map (lambda (x) (trv (hashq-ref touch x #f)))
l)
,@(lp u)))
((x . l)
(cons x (lp l)))
(x x))))
(define (tr-gotos x) (define (tr-gotos x)
(define map (make-hash-table)) (define map (make-hash-table))
...@@ -144,7 +157,7 @@ ...@@ -144,7 +157,7 @@
extvars)) extvars))
(tr-gotos (tr-gotos
(tr-orvars (tr-orvars source?
(let lp ((exp exp) (mode '+)) (let lp ((exp exp) (mode '+))
(match exp (match exp
(((? (m or-tag))) (((? (m or-tag)))
...@@ -169,7 +182,8 @@ ...@@ -169,7 +182,8 @@
((x . l) ((x . l)
(let ((lb (labels)) (let ((lb (labels))
(other (diff all (term-variables s x epred)))) (other (diff all (term-variables s x epred))))
`(,(tr 'next-or) ,(cons #:goto lb) ,other `(,(tr 'next-or) ,(cons #:goto lb)
,other
,@(lp x mode) ,@(lp x mode)
,(cons #:label lb) ,@(lp2 l))))))))) ,(cons #:label lb) ,@(lp2 l)))))))))
...@@ -224,12 +238,17 @@ ...@@ -224,12 +238,17 @@
(if (gp-var? x s) (if (gp-var? x s)
(if (hashq-ref ev x #f) (if (hashq-ref ev x #f)
(aif (r) (hashq-ref touch x #f) (aif (r) (hashq-ref touch x #f)
(list (tr 'unify_external mode) r) (list (tr 'unify_external mode)
(if source?
#`(list-ref external-vars #,r)
(list-ref external-vars r)))
(let ((next-e (ne))) (let ((next-e (ne)))
(hashq-set! touch x next-e) (hashq-set! touch x next-e)
(hashq-set! extvars x next-e) (hashq-set! extvars x next-e)
(list (tr 'match_evar) (list (tr 'match_evar)
(list-ref external-vars next-e)))) (if source?
#`(list-ref external-vars #,next-e)
(list-ref external-vars next-e)))))
(aif (r) (hashq-ref touch x #f) (aif (r) (hashq-ref touch x #f)
(list (tr 'unify_internal mode) r) (list (tr 'unify_internal mode) r)
(let ((next-i (ni))) (let ((next-i (ni)))
...@@ -239,19 +258,35 @@ ...@@ -239,19 +258,35 @@
(define mu (make-fluid '())) (define mu (make-fluid '()))
(define (mapi lam n l)
(let lp ((i n) (l l))
(if (< i 0)
(cons (lam (car l)) (lp (- i 1) (cdr l)))
'())))
(define (mockalambda_ s pat code) (define (for-eachi lam n l)
(let lp ((i n) (l l))
(if (< i 0)
(begin (lam (car l)) (lp (- i 1) (cdr l)))
(if #f #f))))
(define (mockalambda_ source? s pat code)
(define (get-extvars table) (define (get-extvars table)
(define temp '()) (define temp '())
(hash-for-each (hash-for-each
(lambda x (set! temp (cons x temp))) (lambda x (set! temp (cons x temp)))
table) table)
temp) temp)
(set! pp #t)
(pretty-print `(compiled ,(compile-match s pat code))) (define (rep comp)
(set! pp #f) #`(vector #,@(map (lambda (co) #``#,(repr s source? co))
(let* ((comp.table (compile-match s pat code)) (vector->list comp))))
(comp (pk 'comp (car comp.table)))
;(set! pp #t)
;(pretty-print `(compiled ,(compile-match source? s pat code)))
;(set! pp #f)
(let* ((comp.table (compile-match source? s pat code))
(comp (car comp.table))
(table (cdr comp.table)) (table (cdr comp.table))
(extvars (get-extvars table)) (extvars (get-extvars table))
(vars (map car extvars)) (vars (map car extvars))
...@@ -262,8 +297,58 @@ ...@@ -262,8 +297,58 @@
(if (pair? l) (if (pair? l)
(lp (cdr l) (max (car l) i)) (lp (cdr l) (max (car l) i))
i))) i)))
(oth (compile-prolog s pat code #f (list #t #t))) (oth (compile-prolog s pat code source? (list #t #t)))
(lam (compile-prolog s vars code #f (list #t #f)))) (lam (compile-prolog s vars code source? (list #t #f))))
(if source?
#`(let ((o #,oth))
(list
(car o)
#,(case (length fvars)
((0)
#`(lambda (s p cc cut x)
(let ((s (gp-match x #,(rep comp) s)))
(if s
(#,lam s p cc cut)
(p)))))
((1)
#`(let ((co #,(rep comp)))
(lambda (s p cc cut x)
(let ((s (gp-match x co s)))
(if s
(let* ((f (car external-vars))
(v (fluid-ref f)))
(fluid-set! f #f)
(#,lam s p cc cut v))
(p))))))
((2)
#`(let ((co #,(rep comp)))
(lambda (s p cc cut x)
(let ((s (gp-match x co s)))
(if s
(let* ((f1 (car external-vars))
(v1 (fluid-ref f1))
(f2 (cadr external-vars))
(v2 (fluid-ref f2)))
(fluid-set! f1 #f)
(fluid-set! f2 #f)
(#,lam s p cc cut v1 v2))
(p))))))
(else
#`(let ((co #,(rep comp)))
(lambda (s p cc cut x)
(let ((s (gp-match x co s)))
(if s
(let ((vs (mapi (lambda (x) (fluid-ref x))
#,(length fvars) external-vars)))
(for-eachi (lambda (x) (fluid-set! x #f))
#,(length fvars) external-vars)
(apply #,lam s p cc cut vs))
(p)))))))
(cadr o)))
(list (list
(car oth) (car oth)
(case (length fvars) (case (length fvars)
...@@ -305,8 +390,8 @@ ...@@ -305,8 +390,8 @@
(for-each (lambda (x) (fluid-set! x #f)) fvars) (for-each (lambda (x) (fluid-set! x #f)) fvars)
(apply lam s p cc cut vs)) (apply lam s p cc cut vs))
(p)))))) (p))))))
(cadr oth)))) (cadr oth)))))
(define (mockalambda s pat code) (define (mockalambda source? s pat code)
(mockalambda_ s pat code)) (mockalambda_ source? s pat code))
...@@ -671,8 +671,12 @@ ...@@ -671,8 +671,12 @@
<lambda-dyn>) ,aa <lambda-dyn>) ,aa
(,(GL <var>) ,vars ,ff) (,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff))))))))) ,(list (G cons) `,aaa `,fff)))))))))
(if (not source?) (compile (src (list (G lambda)) '()) (if (not source?)
#:env (current-module)) #f))) (if meta-only?
(eval (src (list (G lambda)) '())
(current-module))
(compile (src (list (G lambda)) '())
#:env (current-module))))))
(define (lamlam lam) (define (lamlam lam)
(lambda (f) (lambda (f)
(lam f))) (lam f)))
......
...@@ -14,8 +14,9 @@ ...@@ -14,8 +14,9 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:re-export (define-dynamic define-dynamic! define-dynamic-f) #:re-export (define-dynamic define-dynamic! define-dynamic-f)
#:export (asserta assertz assertaf assertzf #:export (asserta assertz assertaf assertzf
clause retract abolish current_predicate clause retract abolish current_predicate
asserta-source assertz-source)) asserta-source assertz-source
asserta-source+ assertz-source+))
(define once-f #f) (define once-f #f)
(define (maybe-call x) (define (maybe-call x)
(if (@@ (logic guile-log prolog base) *eval-only*) (if (@@ (logic guile-log prolog base) *eval-only*)
...@@ -49,7 +50,8 @@ ...@@ -49,7 +50,8 @@
(<push-dynamic> (<lookup> F) (<push-dynamic> (<lookup> F)
(catch #t (catch #t
(lambda () (lambda ()
(mockalambda (<scm> S) (mockalambda #f
(<scm> S)
(<scm> A) (<scm> A)
(<scm> Body))) (<scm> Body)))
(lambda x (lambda x
...@@ -79,7 +81,7 @@ ...@@ -79,7 +81,7 @@
(<push-dynamic> (<lookup> F) (<push-dynamic> (<lookup> F)
(catch #t (catch #t
(lambda () (lambda ()
(mockalambda (<scm> S) (<scm> A) true)) (mockalambda #f (<scm> S) (<scm> A) true))
(lambda x (lambda x
(format #t "PROLOG HOT COMPILE ERROR:~%~a~%~%" x) (format #t "PROLOG HOT COMPILE ERROR:~%~a~%~%" x)
...@@ -250,6 +252,83 @@ ...@@ -250,6 +252,83 @@
(mk-assert+source asserta-source <push-dynamic>) (mk-assert+source asserta-source <push-dynamic>)
(mk-assert+source assertz-source <append-dynamic>) (mk-assert+source assertz-source <append-dynamic>)
(define-syntax-rule (mk-assert++source asserta <push-dynamic>)
(<define> (asserta stx Arg ext)
(<<match>> (#:mode - #:name asserta) (Arg)
((? <var?>)
(instantiation_error))
(#((":-" Head))
(translate-directive stx Head))
(#(((and Op ":-") 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))
(<cc>
#`(<push-dynamic> #,(datum->syntax stx
(get-name (<lookup> F)))
#,(catch #t
(lambda ()
(mockalambda stx
(<scm> S)
(<scm> A)
(maybe-call (<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))
(<cc>
#`(<push-dynamic> #,(datum->syntax stx (get-name (<lookup> F)))
#,(catch #t
(lambda () (mockalambda stx
(<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 stx (vector (list F)) ext)
(type_error callable Arg))))))
(mk-assert++source asserta-source+ <push-dynamic>)
(mk-assert++source assertz-source+ <append-dynamic>)
(<define> (asserta x . l) (<define> (asserta x . l)
(asserta_ x (if (null? l) #f l))) (asserta_ x (if (null? l) #f l)))
...@@ -411,4 +490,4 @@ ...@@ -411,4 +490,4 @@
(_ (_
(type_error predicate_indicator X)))) (type_error predicate_indicator X))))
(set! (@@ (logic guile-log prolog parser) assertz-source) assertz-source) (set! (@@ (logic guile-log prolog parser) assertz-source+) assertz-source+)
...@@ -965,7 +965,7 @@ ...@@ -965,7 +965,7 @@
(define *term-expansions* (make-fluid '())) (define *term-expansions* (make-fluid '()))
(define *goal-expansions* (make-fluid '())) (define *goal-expansions* (make-fluid '()))
(define term #f) ;; This will be defined later in var.scm (define term #f) ;; This will be defined later in var.scm
(define assertz-source #f) ;; This will be defined in dynamic.scm (define assertz-source+ #f) ;; This will be defined in dynamic.scm
(define term-init-variables #f) ;; defined in var.scm (define term-init-variables #f) ;; defined in var.scm
(define term-get-variables #f) ;; definef in var.scm (define term-get-variables #f) ;; definef in var.scm
...@@ -1119,9 +1119,9 @@ ...@@ -1119,9 +1119,9 @@
(<<match>> (#:mode - #:name expand) (y) (<<match>> (#:mode - #:name expand) (y)
((x . l) ((x . l)
(lp l (cons (<scm> (lp l (cons (<scm>
(assertz-source S (lambda () #f) (lambda (s p x) x) (assertz-source+ S (lambda () #f) (lambda (s p x) x)
stx stx
(<scm> x) #f)) (<scm> x) #f))
r))) r)))
(() (()
(<cc> (pp #`(begin (<cc> (pp #`(begin
......
(define-module (logic guile-log repr)
#:use-module (logic guile-log umatch)
#:export (repr))
(define-syntax-rule (aif (r) p a b) (let ((r p)) (if r a b)))
(define (repr s stx x)
(define map (make-hash-table))
(define (mks x) (datum->syntax stx (procedure-name x)))
(define (mkvar) (datum->syntax stx (gensym "var")))
(define-syntax-rule (check (x y) code ...)
(let ((y #f))
(aif (r) (hashq-ref map x #f)
(if (eq? r #t)
(let ((r (mkvar #f)))
(hashq-set! map x r)
#`,#,r)
#`,#,r)
(begin
(hashq-set! map x #t)
(begin code ...)
(let ((r (hashq-ref map x #f)))
(if (eq? r #t)
(begin
(hashq-set! map x #f)
y)
#`(let* ((#,r (make-variable #f))
(res `#,y))
(variable-set #,r res))))))))
(let lp ((x x))
(let ((x (gp-lookup x s)))
(umatch (#:mode - #:name repr #:status s) (x)
((a . b)
(check (x y)
(let ((aa (lp a))
(bb (lp b)))
(set! y (cons aa bb)))))
(#(a)
(if (symbol? a)
#`#,x
(check (x y)
(let ((aa (lp a)))
(set! y #`,(vector `#,aa))))))
(#(a b)
(if (symbol? a)
#`#,x
(check (x y)
(let ((aa (lp a))
(bb (lp b)))
(set! y #`,(vector `#,aa `#,bb))))))
(_
(cond
((vector? x)
(if (eq? (vector-ref x 0) 'syntax-object)
#`,#,x
#`,(vector #,@(map (lambda (x) #``#,x)
(lp (vector->list x))))))
((symbol? x) (pk x))
((procedure? x)
#`,#,(mks x))
(else x)))))))
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