;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.45
;;; Reason:
;;;  Fix multitudinous bugs in the Falcon compiled-function FBIN format and code.
;;;  Note expecially: DON'T USE FASD-FIXED!!! (It's a subroutine of FASD-CONSTANT,
;;;  which (among other things, is responsible for putting the object in the fasd-table.)
;;;  This is one of a half-dozen ways the FASD and FASL tables were out of synch. Also,
;;;  eliminate numerous gratuitous hirsute operations which really just wanted to be
;;;  subroutines of the main operation.
;;; Written 12-Aug-88 04:46:34 by RWK at site Gigamos Cambridge
;;; while running on Love from band 2
;;; with Experimental System 126.44, ZWEI 125.15, 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/3/88.



; From file DJ: L.SYS; QCFASD.LISP#265 at 12-Aug-88 04:46:34
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFASD  "

(defun fasd-k-compiled-function (function &optional (function-type 'function))
  ;; On the Lambda, of course, FUNCTION can never be anything but a symbol
  ;; or an NCOMPILED-FUNCTION. On the K, however, we'd like FASD-CONSTANT to dump
  ;; them, so we could make NC::GET-NCOMPILED-FUNCTION construnct an NCOMPILED-FUNCTION
  ;; from the actual function. This *IS* possible, I *THINK*. --RWK
  (let* ((fcn (nc::get-ncompiled-function function))
	 (fcn-name (nc::ncompiled-function-name fcn)))
    (fasd-k-function-info
      fcn-name
      (nc::ncompiled-function-local-refs fcn)
      (nc::ncompiled-function-refs fcn)
      (nc::ncompiled-function-immediates fcn)
      (nc::ncompiled-function-entry-points fcn)
      (nc::ncompiled-function-code fcn)
      (nc::ncompiled-function-load-time-evals fcn))
    ;; Now that we have the function put together, put it into the FASD table.
    (let ((fcn-index (fasd-table-add function)))
      (print fasd-table-current-index)
      (ecase function-type
	((function))
	((macro)
	 ;; It's a macro; macroify the cell before storing.
	 (FASD-START-GROUP T 1 FASL-OP-LIST)
	 (FASD-NIBBLE 2)
	 (FASD-CONSTANT 'MACRO)
	 (FASD-START-GROUP NIL 1 FASL-OP-INDEX)
	 (FASD-NIBBLE fcn-index)
	 ;; OK, now arrange to store THIS entry in the function cell,
	 ;; instead of the function itself.
	 (SETQ fcn-index (FASD-TABLE-ADD `(macro ,function)))))
       (if (null fcn-name)
	   (fasd-constant nil)			;Placeholder
      ;; Store the function we allocated a fasl-table entry for
      ;; earlier, into its proper home.
	 (FASD-STORE-FUNCTION-CELL FCN-NAME fcn-index)))))

(defun fasd-k-function-info (name local-refs refs immediates entry-points code load-time-evals)
  (let ((length (length code)))
    (fasd-start-group nil (* length 4) si::fasl-op-k-compiled-function)
    (fasd-k-instructions code)
    (fasd-constant name)
    ;; This has to construct a permanent table, so may as well dump it now.
    (fasd-k-link-info local-refs refs entry-points)
    (fasd-k-immediates immediates)
    (fasd-k-load-time-evals load-time-evals)))

;; Not a group, just a piece of a function.
(defun fasd-k-instructions (code)
  (mapc #'(lambda (instruction)
	    (write-k-instruction instruction))
	  code))

(eval-when (compile load eval)
  (deftype k-instruction () '(unsigned-byte 64))
  )

(defun write-k-instruction (inst)
;  (check-type inst k-instruction)
  (fasd-nibble (ldb (byte 16.  0.) inst))
  (fasd-nibble (ldb (byte 16.  16.) inst))
  (fasd-nibble (ldb (byte 16. 32.) inst)) 
  (fasd-nibble (ldb (byte 16. 48.) inst)))

(defun fasd-k-link-info (local-refs refs entry-points)
  (let ((len (length local-refs)))
    (fasd-start-group nil 0 si::fasl-op-k-local-refs)
    (fasd-constant (// len 2))
    (do ((i 0 (+ i 2)))
	((>= i len))
      (fasd-constant (svref local-refs i))	 ;ref offset
      (fasd-constant (svref local-refs (1+ i))))
    (fasd-table-add local-refs))		;target offset
  (let ((len (length refs)))
    (fasd-start-group nil 0 si::fasl-op-k-refs)
    (fasd-constant (// len 3))
    (do ((i 0 (+ i 3)))
	((>= i len))
      (fasd-constant (svref refs i))		;ref offset
      (fasd-constant (svref refs (1+ i)))	;referenced function name
      (fasd-constant (svref refs (+ i 2))))
    (fasd-table-add refs))			;number of args
  (let ((len (length entry-points)))
    (fasd-start-group nil 0 si::fasl-op-k-entry-points)
    (fasd-constant (// len 2))
    (do ((i 0 (+ i 2)))
	((>= i len))
      (fasd-constant (svref entry-points i))	;number of args
      (fasd-constant (svref entry-points (1+ i))))	;entry offset
    (fasd-table-add entry-points)))

(defun fasd-k-immediates (immediates)
  (let ((len (length immediates)))
    (fasd-constant (// len 2))
    (do ((i 0 (+ i 2)))
	((>= i len))
      (fasd-constant (svref immediates i))		;ref offset
      (fasd-constant (svref immediates (1+ i))))))	;immediate object
    
			
(defun fasd-k-load-time-evals (items)
  (let ((len (length items)))
    (fasd-constant len)
    (loop for (offset form) in items
	  do
	  (fasd-constant offset)			;ref offset
	  (fasd-constant form))))
))