;;;
;;; faslizer.lisp
;;;
;;; fasl file analyzer.
;;;


;; Boilerplate

(cl:defpackage :faslizer
  (:use :common-lisp)
  (:export "FASLIZE-FILE"))

(cl:in-package :faslizer)


;; Utility functions

(defun hexdump (array index base &optional (n #x80))
  (let ((textbuf (make-string 18)))
    (unless (zerop (logand base 15))
      (format t "~(~8,'0X:~)" base))

    (setf (aref textbuf 0) #\|)
  
    (dotimes (i (logand base 15))
      (format t "   ")
      (setf (aref textbuf i) #\Space)
      (setf (aref textbuf (1+ i)) #\|))

    (setf (aref textbuf 17) #\|)
  
    (dotimes (j n)
      (when (zerop (logand 15 (+ base j)))
	(format t "~(~8,'0X:~)" (+ base j)))
      (format t " ~(~2,'0X~)" (aref array (+ index j)))
      (setf (aref textbuf (1+ (logand 15 (+ base j))))
	    (if (and (< (aref array (+ index j)) #x80)
		     (graphic-char-p (code-char (aref array (+ index j)))))
		(code-char (aref array (+ index j)))
		#\.))
      (when (= 15 (logand 15 (+ base j)))
	(format t " ~A~%" textbuf)
	(setf (aref textbuf 0) #\|)))
  
    (unless (zerop (logand 15 (+ base n)))
      (setf (aref textbuf (1+ (logand 15 (+ base n)))) #\|)
      (dotimes (i (- 16 (logand 15 (+ base n))))
	(format t "   ")
	(setf (aref textbuf (+ 2 i (logand 15 (+ base n)))) #\Space))
      (format t " ~A~%" textbuf))))


;; Fasl encoding processing

(defun read-word (fasl)
  (let ((b0 (read-byte fasl))
	(b1 (read-byte fasl)))
    (dpb b1 (byte 8 8) b0)))

(defun read-dword (fasl)
  (let ((w0 (read-word fasl))
	(w1 (read-word fasl)))
    (dpb w1 (byte 16 16) w0)))

(defun read-string (fasl)
  (let* ((length (read-dword fasl))
	 (result (make-array length :element-type 'character)))
    (dotimes (i length result)
      (setf (aref result i) (code-char (read-byte fasl))))))

(defun read-small-string (fasl)
  (let* ((length (read-byte fasl))
	 (result (make-array length :element-type 'character)))
    (dotimes (i length result)
      (setf (aref result i) (code-char (read-byte fasl))))))

;; Header parsing

(defun dump-fasl-header (fasl)
  ;; header text
  (loop
     for octet = (read-byte fasl)
     until (= octet #xff)
     do (princ (code-char octet)))

  ;; target arch
  (format t "arch: ~S~%" (read-string fasl))

  ;; target fasl version
  (format t "fasl version: ~S~%" (read-dword fasl))

  ;; features
  (format t "features: ~S~%" (read-string fasl)))

;; Dispatch table by fopcode

(defvar *fop-dump-table*
  (make-array #x100
	      :initial-element (lambda (fasl octet)
				 (declare (ignore fasl))
				 (format t "unknown fop #x~2,'0X (~S)~%"
					 octet (aref sb-fasl::*fop-names* octet))
				 (throw 'faslize-abort nil))))

;; Fopalizer definition helper

(defmacro defopalize (fop-name args &body forms)
  (let ((octet (get (find-symbol (symbol-name fop-name)
				 (find-package :sb-fasl))
		    'sb-fasl::fop-code)))
    (unless octet
      (error "fop ~S not found" fop-name))
    `(setf (aref *fop-dump-table* ,octet)
	   (lambda (fasl octet)
	     (declare (ignore octet))
	     (funcall (lambda ,args
			(declare (ignorable ,(first args)))
			,@forms)
		      fasl ,(symbol-name fop-name))))))

(defmacro defopalize-noarg (fop-name)
  `(defopalize ,fop-name (fasl name)
     (format t "~A~%" name)))

;; Fopalizers

(defopalize-noarg fop-misc-trap)
(defopalize-noarg fop-pop)
(defopalize-noarg fop-normal-load)
(defopalize-noarg fop-maybe-cold-load)
(defopalize-noarg fop-package)
(defopalize-noarg fop-fdefinition)
(defopalize-noarg fop-truth)
(defopalize-noarg fop-layout)
(defopalize-noarg fop-empty-list)
(defopalize-noarg fop-list-2)
(defopalize-noarg fop-list-3)
(defopalize-noarg fop-list*-2)
(defopalize-noarg fop-list*-5)
(defopalize-noarg fop-sanctify-for-execution)
(defopalize-noarg fop-fset)
(defopalize-noarg fop-verify-empty-stack)
(defopalize-noarg fop-end-group)

(defopalize fop-word-integer (fasl name)
  (format t "~A #x~2,'0X~%" name (read-dword fasl)))

(defopalize fop-byte-integer (fasl name)
  (format t "~A #x~2,'0X~%" name (read-byte fasl)))

(defopalize fop-code-object-fixup (fasl name)
  (format t "~A #x~2,'0X~%" name (read-dword fasl)))

(defopalize fop-fun-entry (fasl name)
  (format t "~A #x~2,'0X~%" name (read-dword fasl)))

(defopalize fop-verify-table-size (fasl name)
  (format t "~A ~S~%" name (read-dword fasl)))

(defopalize fop-byte-push (fasl name)
  (format t "~A ~S~%" name (read-byte fasl)))

(defopalize fop-funcall-for-effect (fasl name)
  (format t "~A ~S~%" name (read-byte fasl)))

(defopalize fop-small-vector (fasl name)
  (format t "~A ~S~%" name (read-byte fasl)))

(defopalize fop-small-struct (fasl name)
  (format t "~A ~S~%" name (read-byte fasl)))

(defopalize fop-small-base-string (fasl name)
  (format t "~A ~S~%" name (read-small-string fasl)))

(defopalize fop-lisp-small-symbol-save (fasl name)
  (format t "~A ~S~%" name (read-small-string fasl)))

(defopalize fop-keyword-small-symbol-save (fasl name)
  (format t "~A ~S~%" name (read-small-string fasl)))

(defopalize fop-small-symbol-in-byte-package-save (fasl name)
  (format t "~A ~S ~S~%" name (read-byte fasl) (read-small-string fasl)))

(defopalize fop-small-code (fasl name)
  (let* ((num-boxed (read-byte fasl))
	 (code-length (read-word fasl))
	 (code-vector (make-array code-length
				  :element-type '(unsigned-byte 8))))
    (format t "~A ~S ~S~%" name num-boxed code-length)
    (read-sequence code-vector fasl)
    (hexdump code-vector 0 0 code-length)))

(defopalize fop-int-vector (fasl name)
  (let* ((len (read-dword fasl))
	 (size (read-byte fasl))
	 (data (make-array (ceiling (* size len) 8)
			   :element-type '(unsigned-byte 8))))
    (format t "~A ~S ~S~%" name len size)
    (read-sequence data fasl)
    (hexdump data 0 0 (length data))))

(defopalize fop-small-integer (fasl name)
  (let* ((len (read-byte fasl))
	 (data (make-array len :element-type '(unsigned-byte 8))))
    (format t "~A ~S~%" name len)
    (read-sequence data fasl)
    (hexdump data 0 0 len)))

(defopalize fop-structset (fasl name)
  (format t "~A ~S ~S~%" name (read-dword fasl) (read-dword fasl)))

;; cold-nonpaged fop

(setf (aref *fop-dump-table* #xdc)
      (lambda (fasl octet)
	(declare (ignore fasl octet))
	(format t "FOP-COLD-NONPAGED~%")))

;; Entry point

(defun faslize-file (filename)
  (with-open-file (fasl filename
			:direction :input
			:element-type '(unsigned-byte 8))
    (dump-fasl-header fasl)

    (catch 'faslize-abort
      (loop
	 for octet = (read-byte fasl nil nil)
	 while octet
	 do (funcall (aref *fop-dump-table* octet) fasl octet)))))

;;; EOF