Prune symbols in serialized object code (for #4)

This commit is contained in:
~keith 2021-12-15 17:23:33 +00:00
parent 67d6fe13b2
commit 62ace0204e
Signed by: keith
GPG Key ID: 5BEBEEAB2C73D520
1 changed files with 89 additions and 43 deletions

View File

@ -59,53 +59,99 @@
tree)
(defun copy-replace-tree (tree atom-fun)
(when tree
(let ((new-car (car tree)) (new-cdr (cdr tree)))
(if (consp new-car)
(setf new-car (copy-replace-tree new-car atom-fun))
(setf new-car (funcall atom-fun new-car)))
(if (consp new-cdr)
(setf new-cdr (copy-replace-tree new-cdr atom-fun))
(setf new-cdr (funcall atom-fun new-cdr)))
(cons new-car new-cdr))))
(let ((new-car (car tree)) (new-cdr (cdr tree)))
(if (consp new-car)
(setf new-car (copy-replace-tree new-car atom-fun))
(setf new-car (funcall atom-fun new-car)))
(if (consp new-cdr)
(setf new-cdr (copy-replace-tree new-cdr atom-fun))
(setf new-cdr (funcall atom-fun new-cdr)))
(cons new-car new-cdr)))
(defun process-load-forms (obj table)
"Update table with the forms necessary to generate obj."
(multiple-value-bind (cons-form init-form)
(make-load-form obj)
(let ((sym (gensym))
(output-cons-forms ())
(output-init-forms ()))
(setf (gethash obj table) sym)
(setf init-form
(copy-replace-tree init-form
(lambda (x)
(cond
;; x has already been processed
((gethash x table))
;; x is an id-ref, just serialize it like this
((typep x 'id-ref)
`(make-id-ref :scene ,(id-ref-scene x)
:actor ,(id-ref-actor x)
:component ,(id-ref-component x)))
;; x needs to be run through process-load-forms
((typep x '(or standard-object structure-object condition class))
(multiple-value-bind (x-cons-forms x-init-forms x-sym)
(process-load-forms x table)
(setf output-cons-forms (nconc output-cons-forms x-cons-forms))
(when x-init-forms
(setf output-init-forms (nconc output-init-forms x-init-forms)))
x-sym))
;; x doesn't need processing
(t x)))))
(setf output-cons-forms (nconc output-cons-forms `((,sym ,cons-form))))
(let ((sym (gensym)))
(setf (gethash obj table) (cons sym (cons cons-form nil)))
(when init-form
(setf output-init-forms (nconc output-init-forms `(,init-form))))
(values output-cons-forms output-init-forms sym))))
(setf init-form
(copy-replace-tree init-form
(lambda (x)
(cond
;; x has already been processed
((gethash x table)
(car (gethash x table)))
;; x is an id-ref, just serialize it like this
((typep x 'id-ref)
`(make-id-ref :scene ,(id-ref-scene x)
:actor ,(id-ref-actor x)
:component ,(id-ref-component x)))
;; x needs to be run through process-load-forms
((typep x '(or standard-object structure-object condition class))
(process-load-forms x table))
;; x doesn't need processing
(t x)))))
(setf (gethash obj table) (cons sym (cons cons-form init-form))))
sym)))
(defun generate-load-forms (obj)
(multiple-value-bind (cons-forms init-forms sym)
(process-load-forms obj (make-hash-table :test #'eq))
`(let ,cons-forms
(defun apply-in-tree (tree atom-fun)
"Run atom-fun on everything in tree. Stop if atom-fun returns nil."
(when tree
(if (if (consp (car tree))
(apply-in-tree (car tree) atom-fun)
(funcall atom-fun (car tree)))
(if (consp (cdr tree))
(apply-in-tree (cdr tree) atom-fun)
(funcall atom-fun (cdr tree)))
nil)
))
(defun prune-form-symbols (table init-forms)
"Replace symbols in init-forms with their cons-form from table if they're only referenced once."
(let ((count-table (make-hash-table)))
;; collect symbols without an init-form
(loop for entry being each hash-value in table
using (hash-key key)
unless (cddr entry)
do (setf (gethash (car entry) count-table) (cons 0 key)))
;; count occurences of prunable symbols
(apply-in-tree init-forms
(lambda (x)
(when (and (symbolp x) (gethash x count-table))
(incf (car (gethash x count-table)) 1))
t))
;; replace symbols that occur exactly once
(replace-in-tree init-forms
(lambda (x)
(if (symbolp x)
(let ((pair (gethash x count-table)))
(if (and pair (= (car pair) 1))
(prog1
(cadr (gethash (cdr pair) table))
(remhash (cdr pair) table))
x))
x)))
))
(defun generate-load-forms (obj &key (prune t))
"Generate code that restores the current state of obj."
(declare (type boolean prune))
(let ((table (make-hash-table :test #'eq))
sym init-forms)
;; serialize
(setf sym (process-load-forms obj table))
;; collect init-forms
(setf init-forms (loop for entry being each hash-value in table
when (cddr entry)
collect it))
;; prune if requested
(when prune (setf init-forms (prune-form-symbols table init-forms)))
;; generate final form
`(let ,(loop for entry being each hash-value in table
;; (sym cons-form)
collect (list (car entry) (cadr entry)))
,@init-forms
,sym)))
,sym)
))