;;; Zapping
;;;
;;; Remove metadata from code
;;;
;;; Remove information not needed at runtime
;;;
;;;
;;; @author Robert Smith original code
;;; @author Anne Ogborn cleanup

(defpackage #:zapping
  (:documentation "Zapping - to remove information not needed at runtime, presumably blah blah TODO")
  (:use :cl)
  (:export #:zap-info))

(defun %zap-c-objects ()
  (sb-c::call-with-each-globaldb-name
   (lambda (name)
     (format t "~%~A" name)
                        ;;; category kind 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)
     #+#: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)
     )))

(defun %zap-allocated-object-xref (obj tag size)
  (declare (ignore size))
  (format t "~%~A ~A ~A" obj (type-of obj) tag)
  (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 (setf (sb-kernel:%simple-fun-info fun) nil)
     ))
    ((= 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)))
  )

(defun %zap-allocated-object (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
         ((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)))
  )

(defun %zap-allocated-objects (purge-xref)
  ;; ANNIE todo declare? types?
  (cond (purge-xref (sb-vm::map-allocated-objects #'%zap-allocated-object-xref))
    (t          (sb-vm::map-allocated-objects #'%zap-allocated-object)))
  :dynamic)

;;; Single keyword parameter :purge-xref, if t
;;;  remove cross reference info
;;;
(defun zap-info (&key (purge-xref t))
  (%zap-allocated-objects purge-xref)
  (%zap-c-objects))