From 62ace0204e5abdfb28f42a3603e32a25734bc46d Mon Sep 17 00:00:00 2001
From: ~keith <keith@keithhacks.cyou>
Date: Wed, 15 Dec 2021 17:23:33 +0000
Subject: [PATCH] Prune symbols in serialized object code (for #4)

---
 wh-engine/serialization.lisp | 132 +++++++++++++++++++++++------------
 1 file changed, 89 insertions(+), 43 deletions(-)

diff --git a/wh-engine/serialization.lisp b/wh-engine/serialization.lisp
index b2b8bac..37f0a4c 100644
--- a/wh-engine/serialization.lisp
+++ b/wh-engine/serialization.lisp
@@ -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)
+    ))