analyze compiles

parent 079e2f3c
......@@ -74,6 +74,7 @@ PSSOURCES = \
logic/guile-log/prolog/goal-functors.scm \
logic/guile-log/prolog/modules.scm \
logic/guile-log/prolog/compile.scm \
logic/guile-log/prolog/analyze.scm \
logic/guile-log/prolog/dynamic.scm \
logic/guile-log/prolog/directives.scm \
logic/guile-log/prolog/order.scm \
......
......@@ -304,6 +304,22 @@ add/run * vlist *
(values r1 r2 r3 (make-empty) #f)))
(values vlist-null r2 r3 (make-empty) #f))))))
(define (compile-inh s y theory)
(match y
(((? (type? s) x) a b c)
(let ((a (compile-inh s a theory))
(c (compile-inh s a theory))
(tree (assoc=>tree theory (car b))))
(list x a (cons (car b) tree) c)))
((x . l)
(let ((xx (compile-inh s x theory))
(ll (compile-inh s l theory)))
(if (and (eq? x xx) (eq? l ll))
y
(cons xx ll))))
(x x)))
(define dive
(case-lambda
((dlink)
......@@ -453,8 +469,7 @@ add/run * vlist *
#f))
(define (bitmap-indexer-add s e f dlink get-set)
(match e
(match e
(((? =..tag?) x)
(bitmap-indexer-add s (vector x) f dlink get-set))
......@@ -967,7 +982,7 @@ add/run * vlist *
(define (compile-index-raw s e)
(let* ((d (get-dyn e))
(set (get-theory e))
(set 0)
(dyn (fold-dynlist-lr
(lambda (x indexer)
(bitmap-indexer-add! s (p (vector-ref x 1))
......@@ -975,12 +990,12 @@ add/run * vlist *
indexer (mk-get-set! set)))
d
(make-indexer))))
(set! set (compile-set-representation set))
(vector
(get-tag e)
d
(dynlist->vlist (get-ar e) d)
dyn
(compile-inh s dyn set)
set)))
(define (compile-index s)
......
......@@ -18,6 +18,7 @@
mk-get-set
mk-get-set!
set<
assoc=>tree
))
;; Syntax helpers
......@@ -119,7 +120,7 @@ This is prepared to make it functional, but currently we mutate
(if set
(lambda (s)
(let* ((i (get-i (get-set->i (fluid-ref *current-set-theory*)) s)))
(set-car! set (logior set i))
(set! set (logior set i))
i))
(lambda (s) 0)))
......@@ -127,7 +128,7 @@ This is prepared to make it functional, but currently we mutate
(if set
(lambda (s)
(let* ((i (get-i (get-set->i (fluid-ref *current-set-theory*)) s)))
(set-car! set (logior set i))
(set! set (logior set i))
i))
(lambda (s) 0)))
......@@ -446,11 +447,20 @@ a natural generational mapping to help in constructing a match tree.
(logior x y))
(() 0)))
(define (assoc=>tree theory a)
(let ((p (get-parent theory))
(set->i (get-set->i theory))
(i->j (get-i->j theory)))
(let lp ((a a) (i->f (make-hash-table)))
(if (pair? a)
(lp (cdr a) (update a (get-i i->j (get-i set->i (caar a))) (cadr a)))
(mktree theory a)))))
(define mktree
(case-lambda*
((#:key (setbits (- (get-new (fluid-ref *current-set-theory*)) 1)))
(mktree (fluid-ref *current-set-theory*) #:setbits setbits))
((theory #:key (setbits (- (get-new theory) 1)))
((i->f #:key (setbits (- (get-new (fluid-ref *current-set-theory*)) 1)))
(mktree (fluid-ref *current-set-theory*) i->f #:setbits setbits))
((theory i->f #:key (setbits (- (get-new theory) 1)))
(define (clusterize setbits)
(let ((i->subs (get-i->subs theory)))
(let lp ((ss (bits-to-is setbits)) (done 0))
......@@ -487,13 +497,12 @@ a natural generational mapping to help in constructing a match tree.
(define setlist (p (linearize (mktree1 setbits))))
(define tree
(let ((i->f (get-i->f theory)))
(let lp ((l (reverse setlist)) (tree (make-dynlist)))
(if (pair? l)
(let ((i (car l)))
(lp (cdr l)
(dynlist-add tree i inh-comb)))
tree))))
(let lp ((l (reverse setlist)) (tree (make-dynlist)))
(if (pair? l)
(let ((i (car l)))
(lp (cdr l)
(dynlist-add tree i inh-comb)))
tree)))
tree)))
#|
......
(define-module (logic guile-log prolog analyze)
#:use-module (logic guile-log)
#:use-module (logic guile-log type)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log guile-prolog copy-term)
#:export (analyze))
(define #{,}# prolog-and)
(<define> (analyze-type in)
(<<match>> (#:mode - #:name analyze-type) (in)
((x . l)
(<and>
(<values> (xx) (analyze-type x))
(<values> (ll) (analyze-type l))
(<cc> (cons xx ll))))
(#(x)
(<and>
(<values> (xx) (analyze-type x))
(<cc> (vector xx))))
(#(x y)
(<and>
(<values> (xx) (analyze-type x))
(<values> (yy) (analyze-type y))
(<cc> (vector xx yy))))
(x
(<let> ((x (<lookup> x)))
(<var> (v)
(<if> (<get-attr> x Type v)
(<and>
(<values> (vv) (analyze-type v))
(<cc> (list Type x vv)))
(<cc> x)))))))
(<define> (analyze in goal)
(<values> (in) (analyze-type in))
(<values> (in.goal extra) (duplicate-term-3 (cons in goal)))
(<let> ((in (car in.goal))
(goal (cdr in.goal)))
(<cc> in (let lp ((l extra))
(if (pair? l)
(vector #{,}# (car l) (lp (cdr l)))
goal)))))
(define-module (logic guile-log prolog compile)
#:use-module (logic guile-log guile-prolog closure)
#:use-module (logic guile-log guile-prolog copy-term)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 match)
#:use-module (ice-9 time)
......@@ -240,7 +241,8 @@
((and (struct? x) (prolog-closure? x))
(add-fkn (prolog-closure-parent x))
(for-each* scan-goal (prolog-closure-state x)))
(else
(else
#t)))))
(define (compile-a match-map-i x)
......@@ -645,18 +647,18 @@
(define src #f)
(define lam
(with-fluids ((*current-language* (lookup-language 'scheme)))
(set! src
(lambda (lam u)
(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-meta>) ,aa
,(list (G cons) `,aaa `,fff))))))
(set! src
(lambda (lam u)
(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-meta>) ,aa
,(list (G cons) `,aaa `,fff))))))
(fast-compile?
(pp 'comp
......
......@@ -7,6 +7,7 @@
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog analyze)
#:use-module (logic guile-log prolog var)
#:use-module ((logic guile-log prolog util)
#:select ((member . pr-member)))
......
......@@ -4,7 +4,7 @@
#:select (gp-attvar-raw? set-attribute-cstor! gp-lookup
gp-make-var gp-get-attr
gp-attvar?))
#:use-module (logic guile-log inheritance)
#:export (type? type Type))
......
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