first persistance steps

parent 3743dcfc
......@@ -18,6 +18,7 @@ PSSOURCES = \
ice-9/vset.scm \
logic/guile-log/scmspace.scm \
logic/guile-log/fstream.scm \
logic/guile-log/persistance.scm \
logic/guile-log/guile-log-pre.scm \
logic/guile-log/ck.scm \
logic/guile-log/vlist.scm \
......
......@@ -122,6 +122,8 @@
gp-get-taglist
gp-match
gp-bv-address
))
;; Tos silence the compiler, those are fetched from the .so file
......
(define-module (logic guile-log persistance)
#:use-module (system vm loader)
#:use-module (system vm program)
#:use-module (logic guile-log code-load)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:export (make-logger persist))
(define gp-var 0)
(define var 1)
(define fluid 2)
(define pair 3)
(define vector 4)
(define procedure 5)
(define struct 6)
(define named 7)
(define gp-pair 8)
(define set-gp-var 20)
(define set-var 21)
(define set-fluid 22)
(define set-pair 23)
(define set-vector 24)
(define set-procedure 25)
(define set-struct 26)
(define set-gp-pair 28)
(define* (make-logger #:key (file "persist.scm"))
(let ((maps (make-hash-table))
(imap 0)
(res '())
(i 0)
(obj->i (make-hash-table)))
(define inc
(case-lambda
(()
(let ((res i))
(set! i (+ i 1))))
((x)
(let ((i (inc)))
(hashq-set! obj->i x i)
i))))
(define (add x)
(set! res (cons c res)))
(define-syntax-rule (mk-obj i obj code ...)
(let ((i (hashq-ref obj->j obj #f)))
(if i
i
(let ((i (inc x)))
(update (begin code ...))
i))))
(case-lambda
((kind)
(case kind
((print)
(pretty-print (reverse res)))))
((kind i j k l)
(case kind
((set-procedure)
(update `(,set-procedure ,i ,j ,k ,l)))))
((kind i j k)
(case kind
((set-gp-var)
(update `(,set-gp-var ,i ,j ,k)))
((set-pair)
(update `(,set-pair ,i ,j ,k)))))
((kind i j)
(case kind
((set-var)
(update `(,set-var ,i ,j)))
((set-fluid)
(update `(,set-fluid ,i ,j ,k)))
((set-vector)
(update `(,set-vector ,i ,j ,k)))))
((kind x)
(case kind
((reg-code)
(let ((r (hash-ref map pth #f)))
(if r
r
(let ((i imap))
(set! imap (+ i 1))
(hash-set! map pth i)
i))))
((lookup)
(hashq-ref obj->i x #f))
((named)
(define (mk procedure-property)
(let ((path (procedure-property x 'path)))
(if path
(let ((i (inc x)))
(update `(,named ,path ,i))
i)
#f)))
(if (procedure? x)
(mk procedure-property)
(mk object-property)))
((make-gp-var)
(mk-obj i x
`(,gp-var ,i)))
((make-var)
(mk-obj i x
`(,var ,i)))
((make-gp-fluid)
(mk-obj i x
`(,fluid ,i)))
((make-pair)
(mk-obj i x
`(,pair ,i)))
((make-gp-pair)
(mk-obj i x
`(,gp-pair ,i)))
((make-struct)
(mk-obj i x
`(,struct ,i)))
((make-vector)
(mk-obj i x
`(,vector ,i)))
((make-procedure)
(mk-obj i x
`(,procedure ,i))))))))
(define (persist log x s)
(define-syntax-rule (mk-name make-var x l ...)
(let ((i (log 'named x)))
(if i
i
(log make-var x l ...))))
(define-syntax-rule (do-if-deep x i code)
(define (f n) (not (n x 'shallow)))
(define (p)
(if (procedure? x)
(f procedure-property)
(f object-property)))
(if (p) code)
i)
(define (make-a-var)
(let ((i (mk-name 'make-var x)))
(do-if-deep x i
(let ((j (persist log (variable-ref x) s)))
(log 'set-var i j)))))
(define (make-a-fluid)
(let ((i (mk-name 'make-fluid x)))
(do-if-deep x i
(let ((j (persist log (fluid-ref x) s)))
(log 'set-fluid i j)))))
(define (make-a-gp-var)
(let ((i (mk-name 'make-gp-var x)))
(do-if-deep x i
(let* ((id (gp-get-id-data x))
(v (gp-get-var-var x))
(j (persist log v s)))
(log 'set-gp-var i id j)))))
(define (make-a-pair)
(let ((i (mk-name 'make-pair x)))
(do-if-deep x i
(let* ((h (car x))
(t (cdr x))
(j (persist log h s))
(k (persist log t s)))
(log 'set-car-cdr i j k)))))
(define (make-a-vector)
(let ((n (vector-length x))
(i (mk-name 'make-vector x n)))
(do-if-deep x i
(let ((l (map (lambda (x) (persist log x s))
(vector->list x))))
(log 'set-vector i l)))))
(define (make-a-procedure)
(let ((i (mk-name 'make-procedure x)))
(do-if-deep x i
(let ((addr (program-code x))
(elf (find-mapped-elf-image))
(elfaddr (gp-bv-addr))
(reladdr (- addr elfaddr))
(free (program-free-variables x))
(nfree (length free))
(source (match (find-program-sources addr)
(() #f)
((source . _) source)))
(path (if source
(map (string-split (source:file source) #\/)
((x ... e) (append
(map string->symbol x)
(list
(match (string-split e #\.)
((x ... scm)
(string->symbol
(string-join x "."))))))))
(error "could not translate a procedure")))
(icode (log reg-code path))
(l (map (lambda (x) (persist log x s)) free)))
(log 'set-procedure i icode reladdr l)))))
(define-syntax-rule (mk code)
(let ((i (log 'lookup x)))
(if i
i
(code))))
(cond
((gp-var? x)
(mk make-a-gp-var))
((variable? x)
(mk make-a-var))
((fluid? x)
(mk make-a-fluid))
((pair? x)
(mk make-a-pair))
((vector? x)
(mk make-a-vector))
((struct? x))
((procedure? x)
(mk make-a-procedure))
(else
(mk atom))))
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