Remove ZAP-INFO (#266)

It was a relic from the non-opensource days.

Author: notmgsk

app-ng/src/impl/sbcl.lisp

@@ -2,76 +2,6 @@
 
 (in-package #:qvm-app-ng)
 
-(defun %zap-info (&key (purge-xref t))
-  (sb-vm::map-allocated-objects
-   (lambda (obj tag size)
-     (declare (ignore size))
-     (cond
-       ((= tag sb-vm:code-header-widetag)
-        (setf (sb-kernel:%code-debug-info obj) nil)
-        (loop for fun = (sb-kernel:%code-entry-points obj)
-                then (sb-kernel:%simple-fun-next fun)
-              while fun
-              do (cond
-                   ((or purge-xref
-                        (stringp (sb-kernel:%simple-fun-info fun)))
-                    (setf (sb-kernel:%simple-fun-info fun) nil))
-                   ((consp (sb-kernel:%simple-fun-info fun))
-                    (setf (sb-kernel:%simple-fun-info fun)
-                          (cdr (sb-kernel:%simple-fun-info fun)))))))
-       ((= tag sb-vm:instance-widetag)
-        (cond ((typep obj 'method-combination)
-               (setf (slot-value obj 'sb-pcl::%documentation) nil))
-              ((typep obj 'standard-method)
-               (setf (slot-value obj 'sb-pcl::%documentation) nil))
-              ((typep obj 'class)
-               (setf (slot-value obj 'sb-pcl::%documentation) nil))
-              ((typep obj 'sb-mop:standard-slot-definition)
-               (setf (slot-value obj 'sb-pcl::%documentation) nil))))
-       ((and (= tag sb-vm:funcallable-instance-widetag)
-             (typep obj 'generic-function))
-        (setf (slot-value obj 'sb-pcl::%documentation) nil))))
-   :dynamic)
-  (sb-c::call-with-each-globaldb-name
-   (lambda (name)
-     (sb-int:clear-info :variable :documentation name)
-     (sb-int:clear-info :type :documentation name)
-     (sb-int:clear-info :type :source-location name)
-     (sb-int:clear-info :typed-structure :documentation name)
-     (sb-int:clear-info :setf :documentation name)
-     (sb-int:clear-info :random-documentation :stuff name)
-     (sb-int:clear-info :source-location :variable name)
-     (sb-int:clear-info :source-location :constant name)
-     (sb-int:clear-info :source-location :typed-structure name)
-     (sb-int:clear-info :source-location :symbol-macro name)
-     ;; Doesn't exist in SBCL 1.4.7
-     #+#:ignore
-     (sb-int:clear-info :source-location :vop name)
-     (sb-int:clear-info :source-location :declaration name)
-     (sb-int:clear-info :source-location :alien-type name)
-     ;; Doesn't exist in SBCL 1.4.7
-     #+#:ignore
-     (unless (or (and (symbolp name)
-                      (find (package-name (symbol-package name))
-                            '("SB-KERNEL"
-                              "SB-PCL"
-                              "SB-IMPL")
-                            :test #'string-equal))
-                 (find name '((COMMON-LISP:SETF SB-PCL::CLOS-SLOTS-REF)
-                              QVM::NAT-TUPLE-CARDINALITY
-                              QVM::INJECT-BIT)
-                       :test #'equalp))
-       (sb-int:clear-info :function :inline-expansion-designator name))
-     ;; TODO: package documentation
-     ;;       package location
-     )))
-
-(defun zap-info ()
-  (format t "~&Zapping info...~%")
-  (%zap-info)
-  (format t "~&Garbage collecting...~%")
-  (sb-ext:gc :full t))
-
 (defun disable-debugger ()
   (sb-ext:disable-debugger))
 

app/src/impl/clozure.lisp

@@ -2,10 +2,6 @@
 
 (in-package #:qvm-app)
 
-(defun zap-info ()
-  ;; No-op on Clozure
-  )
-
 (defun start-shm-info-server (name length)
   "Start a thread with a socket listening on the local socket
   /tmp/<NAME>. For any incoming connection, read a single octet, then

app/src/impl/sbcl.lisp

@@ -2,76 +2,6 @@
 
 (in-package #:qvm-app)
 
-(defun %zap-info (&key (purge-xref t))
-  (sb-vm::map-allocated-objects
-   (lambda (obj tag size)
-     (declare (ignore size))
-     (cond
-       ((= tag sb-vm:code-header-widetag)
-        (setf (sb-kernel:%code-debug-info obj) nil)
-        (loop for fun = (sb-kernel:%code-entry-points obj)
-                then (sb-kernel:%simple-fun-next fun)
-              while fun
-              do (cond
-                   ((or purge-xref
-                        (stringp (sb-kernel:%simple-fun-info fun)))
-                    (setf (sb-kernel:%simple-fun-info fun) nil))
-                   ((consp (sb-kernel:%simple-fun-info fun))
-                    (setf (sb-kernel:%simple-fun-info fun)
-                          (cdr (sb-kernel:%simple-fun-info fun)))))))
-       ((= tag sb-vm:instance-widetag)
-        (cond ((typep obj 'method-combination)
-               (setf (slot-value obj 'sb-pcl::%documentation) nil))
-              ((typep obj 'standard-method)
-               (setf (slot-value obj 'sb-pcl::%documentation) nil))
-              ((typep obj 'class)
-               (setf (slot-value obj 'sb-pcl::%documentation) nil))
-              ((typep obj 'sb-mop:standard-slot-definition)
-               (setf (slot-value obj 'sb-pcl::%documentation) nil))))
-       ((and (= tag sb-vm:funcallable-instance-widetag)
-             (typep obj 'generic-function))
-        (setf (slot-value obj 'sb-pcl::%documentation) nil))))
-   :dynamic)
-  (sb-c::call-with-each-globaldb-name
-   (lambda (name)
-     (sb-int:clear-info :variable :documentation name)
-     (sb-int:clear-info :type :documentation name)
-     (sb-int:clear-info :type :source-location name)
-     (sb-int:clear-info :typed-structure :documentation name)
-     (sb-int:clear-info :setf :documentation name)
-     (sb-int:clear-info :random-documentation :stuff name)
-     (sb-int:clear-info :source-location :variable name)
-     (sb-int:clear-info :source-location :constant name)
-     (sb-int:clear-info :source-location :typed-structure name)
-     (sb-int:clear-info :source-location :symbol-macro name)
-     ;; Doesn't exist in SBCL 1.4.7
-     #+#:ignore
-     (sb-int:clear-info :source-location :vop name)
-     (sb-int:clear-info :source-location :declaration name)
-     (sb-int:clear-info :source-location :alien-type name)
-     ;; Doesn't exist in SBCL 1.4.7
-     #+#:ignore
-     (unless (or (and (symbolp name)
-                      (find (package-name (symbol-package name))
-                            '("SB-KERNEL"
-                              "SB-PCL"
-                              "SB-IMPL")
-                            :test #'string-equal))
-                 (find name '((COMMON-LISP:SETF SB-PCL::CLOS-SLOTS-REF)
-                              QVM::NAT-TUPLE-CARDINALITY
-                              QVM::INJECT-BIT)
-                       :test #'equalp))
-       (sb-int:clear-info :function :inline-expansion-designator name))
-     ;; TODO: package documentation
-     ;;       package location
-     )))
-
-(defun zap-info ()
-  (format t "~&Zapping info...~%")
-  (%zap-info)
-  (format t "~&Garbage collecting...~%")
-  (sb-ext:gc :full t))
-
 #+windows
 (defun start-shm-info-server (name length)
   ;; TODO Better description?

build-app-ng.lisp

@@ -33,7 +33,6 @@
     (load-systems-table)
     (push #'local-system-search asdf:*system-definition-search-functions*)
     (asdf:load-system "qvm-app-ng")
-    ;; (funcall (read-from-string "qvm-app-ng::zap-info"))
     (funcall (read-from-string "qvm-app-ng::disable-debugger"))
     (when (find "--qvm-sdk" sb-ext:*posix-argv* :test 'string=)
       (load "app/src/mangle-shared-objects.lisp"))

build-app.lisp

@@ -36,7 +36,6 @@
     (load-systems-table)
     (push #'local-system-search asdf:*system-definition-search-functions*)
     (asdf:load-system "qvm-app")
-    ;; (funcall (read-from-string "qvm-app::zap-info"))
     (funcall (read-from-string "qvm-app::setup-debugger"))
     (when (find "--qvm-sdk" sb-ext:*posix-argv* :test 'string=)
       (load "app/src/mangle-shared-objects.lisp"))