;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.65 ;;; Reason: ;;; improved unfasling of K-FUNCTIONs ;;; pfc ;;; Written 23-Aug-88 16:13:29 by PFC (Peter F. Cerrato) at site Gigamos Cambridge ;;; while running on Death from band 3 ;;; with Experimental System 126.63, ZWEI 125.19, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.13, SDU ROM 102, Kcold loaded 8/17/88. ; From modified file DJ: L.SYS2; UNFASL.LISP#26 at 23-Aug-88 16:15:24 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; UNFASL  " (DEFUN UNFASL-GROUP (&optional top-level-p) (LET (FASL-GROUP-FLAG FASL-GROUP-BITS FASL-GROUP-TYPE FASL-GROUP-LENGTH) (SETQ FASL-GROUP-BITS (UNFASL-NIBBLE)) (IF (= 0 (LOGAND FASL-GROUP-BITS %FASL-GROUP-CHECK)) (FERROR "Fasl group nibble without check bit: ~O" FASL-GROUP-BITS)) (SETQ FASL-GROUP-FLAG (NOT (= 0 (LOGAND FASL-GROUP-BITS %FASL-GROUP-FLAG)))) (SETQ FASL-GROUP-LENGTH (LDB %%FASL-GROUP-LENGTH FASL-GROUP-BITS)) (AND (= FASL-GROUP-LENGTH #o377) (SETQ FASL-GROUP-LENGTH (UNFASL-NIBBLE))) (SETQ FASL-GROUP-TYPE (LOGAND FASL-GROUP-BITS %FASL-GROUP-TYPE)) (OR (< FASL-GROUP-TYPE UNFASL-GROUP-DISPATCH-SIZE) (FERROR "erroneous fasl group type: ~O" FASL-GROUP-TYPE)) (when top-level-p (unfasl-terpri)) ;blank line between top level groups (when (or top-level-p *unfasl-print*) (UNFASL-TERPRI) (WRITE-CHAR #/() (PRIN1 (NTH FASL-GROUP-TYPE FASL-OPS))) (PROG1 (FUNCALL (CL:AREF UNFASL-GROUP-DISPATCH FASL-GROUP-TYPE)) (UNLESS (ZEROP FASL-GROUP-LENGTH) (FORMAT T "~%FASL-GROUP-COUNT wrong: ~D nibbles left over.~%" FASL-GROUP-LENGTH)) (when (or top-level-p *unfasl-print*) (WRITE-CHAR #/)))))) )) ; From modified file DJ: L.SYS2; UNFASL.LISP#26 at 23-Aug-88 17:14:06 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; UNFASL  " (defun unfasl-op-k-compiled-function () (let ((length (ash fasl-group-length -2)) (function (nc::make-ncompiled-function))) (setf (nc:ncompiled-function-code function) (unfasl-k-function-instructions length)) (let ((name (unfasl-next-value)) (local-refs (unfasl-next-value)) (refs (unfasl-next-value)) (entry-points (unfasl-next-value))) (setf (nc::ncompiled-function-name function) name) (setf (nc::ncompiled-function-length function) length) (setf (nc::ncompiled-function-local-refs function) local-refs) (setf (nc::ncompiled-function-refs function) refs) (setf (nc::ncompiled-function-entry-points function) entry-points)) (setf (nc:ncompiled-function-immediates function) (unfasl-k-function-immediates)) (setf (nc:ncompiled-function-load-time-evals function) (unfasl-k-function-load-time-evals)) ;; Now we've got it all hooked up, let's put it into the UNFASL table. (enter-unfasl-table function) (let ((*unfasl-indentation* (+ *unfasl-indentation* 2))) (unfasl-terpri) ;; FASL-OP-STOREIN-FUNCTION-CELL (unfasl-group) (when *unfasl-print* (unfasl-terpri) (unfasl-terpri) (format t "Disassembled Code for ~s" (nc::ncompiled-function-name function)) (unfasl-terpri) (dolist (inst (nc::ncompiled-function-code function)) (unfasl-terpri) (format t "~a" (nc:dis inst))) (unfasl-terpri) (unfasl-terpri))) )) (defun unfasl-read-k-instruction () (let ((1st (unfasl-next-nibble)) (2nd (unfasl-next-nibble)) (3rd (unfasl-next-nibble)) (4th (unfasl-next-nibble))) (dpb 4th (byte 16. 48.) (dpb 3rd (byte 16. 32.) (dpb 2nd (byte 16. 16.) (dpb 1st (byte 16. 0.) 0)))))) (defun unfasl-k-function-instructions (length) (let ((code '())) (dotimes (i length) (push (unfasl-read-k-instruction) code)) (nreverse code))) (defun unfasl-op-k-local-refs () (let ((locals (unfasl-next-value))) (when *unfasl-print* (format t " number of local-refs")) (do ((i 0 (+ i 2)) (locs (unfasl-make-vector (* 2 locals)))) ((>= i (* 2 locals)) (enter-unfasl-table locs)) (setf (aref locs i) (unfasl-next-value)) (when *unfasl-print* (format t " ref offset")) (setf (aref locs (1+ i)) (unfasl-next-value)) (when *unfasl-print* (format t " target offset"))))) (defun unfasl-op-k-refs () (let ((k-refs (unfasl-next-value))) (when *unfasl-print* (format t " number of refs")) (do ((i 0 (+ i 3)) (refs (unfasl-make-vector (* 3 k-refs)))) ((>= i (* 3 k-refs)) (enter-unfasl-table refs)) (setf (aref refs i) (unfasl-next-value)) (when *unfasl-print* (format t " ref offset")) (setf (aref refs (1+ i)) (unfasl-next-value)) (when *unfasl-print* (format t " referenced function name")) (setf (aref refs (+ 2 i)) (unfasl-next-value)) (when *unfasl-print* (format t " number of args"))))) (defun unfasl-op-k-entry-points () (let ((entries (unfasl-next-value))) (when *unfasl-print* (format t " number of entry points")) (do ((i 0 (+ i 2)) (ents (unfasl-make-vector (* 2 entries)))) ((>= i (* 2 entries)) (enter-unfasl-table ents)) (setf (aref ents i) (unfasl-next-value)) (when *unfasl-print* (format t " number of args")) (setf (aref ents (1+ i)) (unfasl-next-value)) (when *unfasl-print* (format t " entry offset"))))) (defun unfasl-k-function-immediates () (let ((immeds (unfasl-next-value))) (when *unfasl-print* (format t " number of immediates")) (do ((i 0 (+ i 2)) (imms (unfasl-make-vector (* 2 immeds)))) ((>= i (* 2 immeds)) imms) (setf (aref imms i) (unfasl-next-value)) (when *unfasl-print* (format t " ref offset")) (setf (aref imms (1+ i)) (unfasl-next-value)) (when *unfasl-print* (format t " immediate object"))))) (defun unfasl-k-function-load-time-evals () (let ((number-of-evals (unfasl-next-value))) (when *unfasl-print* (format t " number of load-time evals")) (do ((i 0 (+ i 2)) (evals (unfasl-make-vector (* 2 number-of-evals)))) ((>= i (* 2 number-of-evals)) evals) (setf (aref evals i) (unfasl-next-value)) (when *unfasl-print* (format t " ref offset")) (setf (aref evals (1+ i)) (unfasl-next-value)) (when *unfasl-print* (format t " form to eval"))))) ))