clpfd compiles and loades with the new fastmatch lambdas

parent 5987916d
......@@ -22,6 +22,7 @@ PSSOURCES = \
logic/guile-log/vlist.scm \
logic/guile-log/indexer.scm \
logic/guile-log/umatch.scm \
logic/guile-log/repr.scm \
logic/guile-log/match.scm \
logic/guile-log/attributed.scm \
logic/guile-log/macros.scm \
......
......@@ -204,7 +204,7 @@ mkdyn([[X|L]],(make_dynamic(X),U)) :- mkdyn(L,U).
all((X : Y) :- Z) :- !,fail.
all((H :- X)) :- !,
assertz(H :- call(X)),
assertzf(H :- call(X)),
fail.
all((:- Head)) :- !,
......@@ -222,7 +222,7 @@ all(Head) :-
(
Head =.. [F|L] ->
(
assertz(Head)
assertzf(Head)
) ;
atom(Head) -> assertz(Head)
),
......
......@@ -2,6 +2,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log repr)
#:export (compile-match mockalambda))
(define compile-prolog #f)
......@@ -78,7 +79,7 @@
(set! n (+ n 1))
r)))
(define (compile-match s exp res)
(define (compile-match source? s exp res)
(define labi 0)
(define labels (mk labi))
......@@ -111,17 +112,29 @@
(lambda (x)
(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)))))
(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)))
`(,a ,x ,(map (lambda (x) (trv (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)))
`(,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)
......@@ -144,7 +157,7 @@
extvars))
(tr-gotos
(tr-orvars
(tr-orvars source?
(let lp ((exp exp) (mode '+))
(match exp
(((? (m or-tag)))
......@@ -169,7 +182,8 @@
((x . l)
(let ((lb (labels))
(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)
,(cons #:label lb) ,@(lp2 l)))))))))
......@@ -224,12 +238,17 @@
(if (gp-var? x s)
(if (hashq-ref ev 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)))
(hashq-set! touch x next-e)
(hashq-set! extvars x next-e)
(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)
(list (tr 'unify_internal mode) r)
(let ((next-i (ni)))
......@@ -239,19 +258,35 @@
(define mu (make-fluid '()))
(define (mockalambda_ s pat code)
(define (mapi lam n l)
(let lp ((i n) (l l))
(if (< i 0)
(cons (lam (car l)) (lp (- i 1) (cdr l)))
'())))
(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 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)))
(define (rep comp)
#`(vector #,@(map (lambda (co) #``#,(repr s source? co))
(vector->list comp))))
;(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))
(extvars (get-extvars table))
(vars (map car extvars))
......@@ -262,8 +297,58 @@
(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))))
(oth (compile-prolog s pat code source? (list #t #t)))
(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
(car oth)
(case (length fvars)
......@@ -305,8 +390,8 @@
(for-each (lambda (x) (fluid-set! x #f)) fvars)
(apply lam s p cc cut vs))
(p))))))
(cadr oth))))
(cadr oth)))))
(define (mockalambda s pat code)
(mockalambda_ s pat code))
(define (mockalambda source? s pat code)
(mockalambda_ source? s pat code))
......@@ -671,8 +671,12 @@
<lambda-dyn>) ,aa
(,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff)))))))))
(if (not source?) (compile (src (list (G lambda)) '())
#:env (current-module)) #f)))
(if (not source?)
(if meta-only?
(eval (src (list (G lambda)) '())
(current-module))
(compile (src (list (G lambda)) '())
#:env (current-module))))))
(define (lamlam lam)
(lambda (f)
(lam f)))
......
......@@ -15,7 +15,8 @@
#:re-export (define-dynamic define-dynamic! define-dynamic-f)
#:export (asserta assertz assertaf assertzf
clause retract abolish current_predicate
asserta-source assertz-source))
asserta-source assertz-source
asserta-source+ assertz-source+))
(define once-f #f)
(define (maybe-call x)
(if (@@ (logic guile-log prolog base) *eval-only*)
......@@ -49,7 +50,8 @@
(<push-dynamic> (<lookup> F)
(catch #t
(lambda ()
(mockalambda (<scm> S)
(mockalambda #f
(<scm> S)
(<scm> A)
(<scm> Body)))
(lambda x
......@@ -79,7 +81,7 @@
(<push-dynamic> (<lookup> F)
(catch #t
(lambda ()
(mockalambda (<scm> S) (<scm> A) true))
(mockalambda #f (<scm> S) (<scm> A) true))
(lambda x
(format #t "PROLOG HOT COMPILE ERROR:~%~a~%~%" x)
......@@ -250,6 +252,83 @@
(mk-assert+source asserta-source <push-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)
(asserta_ x (if (null? l) #f l)))
......@@ -411,4 +490,4 @@
(_
(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 @@
(define *term-expansions* (make-fluid '()))
(define *goal-expansions* (make-fluid '()))
(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-get-variables #f) ;; definef in var.scm
......@@ -1119,7 +1119,7 @@
(<<match>> (#:mode - #:name expand) (y)
((x . l)
(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
(<scm> x) #f))
r)))
......
(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