;;; This is a -*-Lisp-*- file.
;;; %%% To do later: %%%
;;; Clean all this garbage up and make it faster!
;;; Dispatch hackery.
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; Assembler for the Common Lisp Compiler. Runs in Common Lisp.
;;; Accepts LAP code, turns it to FASLAP format code.
;;; Written by many hands: Joe Ginder, Scott Fahlman, Dave Dill,
;;; Walter van Roggen, and Skef Wholey.
;;; Currently maintained by Scott Fahlman.
;;; See compilation and loading instructions in COMPILE-CLC.
;;; Version number.
(proclaim '(special assembler-version))
(setq assembler-version "1.0")
(proclaim '(special *lisp-package* *keyword-package*))
;;;; VARIABLE DECLARATIONS.
;;; List of (TAG . POSITION) for each tag within a function.
(defvar tag-values)
;;; List of numberic bytes codes derived from the LAP code for a function.
(defvar byte-code)
;;; Macro to put a new byte code onto the list.
(defmacro push-byte (b) `(push ,b byte-code))
;;; Count of bytes so far in function.
(defvar nbytes)
;;; List of branch-destination items that also appear in BYTE-CODE.
(defvar tag-refs)
;;; Next slot to be filled in the fasload table. Reset at the start of
;;; each new FASL file.
(defvar fop-table-counter 0)
;;; For speed, we keep the table index for each symbol in a property
;;; under that symbol, rather than in an A-list. All the symbols with
;;; FOP-TABLE-INDEX properties are kept on this list, so that we can
;;; clean up when a new FASL file is started.
(defvar fop-table-symbol-list nil)
;;; FOP-TABLE-PACKAGE-LIST is an a-list mapping packages to their fop-table
;;; indices. Each entry is (package . index).
(defvar fop-table-package-list nil)
;;;; RANDOM UTILITIES.
;;; Dump a single byte to the *CLC-FASL-STREAM* file. We buffer these until
;;; we collect 512 of them, and then write-string them to the FASL stream.
(defvar *dump-byte-buffer* (make-array 512 :element-type '(mod 256)))
(defvar *dump-byte-index*)
(defun dump-dump-byte-buffer ()
(write-string *dump-byte-buffer* *clc-fasl-stream* 0 *dump-byte-index*)
(setq *dump-byte-index* 0))
(defmacro dump-byte (b)
`(progn
(if (= *dump-byte-index* 512)
(dump-dump-byte-buffer))
(setf (aref *dump-byte-buffer* *dump-byte-index*) (logand ,b #x+FF))
(incf *dump-byte-index*)))
;;; Put out the code for one FASL-format operator.
(defun dump-fop (fs)
(let ((val (get fs 'fop-code)))
(if (null val)
(error "Compiler bug: ~S not a legal fasload operator." fs)
(dump-byte val))))
;;;; TOP LEVEL ENTRY POINTS
;;; This function is called from the compiler to initialize the output file
;;; for the Fasload format. Assumes that the file is already open for
;;; 8-bit output and that the output stream is *CLC-FASL-STREAM*.
(defun init-fasl-file ()
;; We now have a virgin FOP-TABLE, so clean up any old stuff.
(setq fop-table-counter 0)
;; Just in case this didn't get cleaned up after an earlier compile.
(cond (fop-table-symbol-list
(do ((sl fop-table-symbol-list (cdr sl)))
((null sl) (setq fop-table-symbol-list nil))
(remprop (car sl) 'fop-table-index))))
;; Clear the package alist.
(setq fop-table-package-list nil)
;; Reset the dump-byte buffer
(setq *dump-byte-index* 0)
;; Print header stuff.
(princ "FASL FILE " *clc-fasl-stream*)
(format *clc-fasl-stream* "~%Fasl code for file ~A." input-filename)
(format *clc-fasl-stream*
"~%Compiler version ~A, assembler version ~A, for ~A/~A.~%"
compiler-version assembler-version target-machine target-system)
;; Mark start of FASL code.
(dump-byte 255)
;; Perq code format.
(dump-fop 'fop-code-format)
(dump-byte 0))
;;; This function is called from the compiler to terminate the Fasl file
;;; whose object is in *CLC-FASL-STREAM*. Does not close the file.
(defun terminate-fasl-file ()
(dump-fop 'fop-verify-empty-stack)
(dump-fop 'fop-end-group)
(dump-dump-byte-buffer)
(do ((sl fop-table-symbol-list (cdr sl)))
((null sl) (setq fop-table-symbol-list nil))
(remprop (car sl) 'fop-table-index)))
;;; This function is called from the compiler to dump random forms occurring
;;; in the file being compiled. These are to be evaluated at load time.
(defun fasl-dump-form (form)
(dump-object form)
(dump-fop 'fop-eval-for-effect))
;;;; THE ASSEMBLER
;;; This is the function called from the compiler to assemble the LAP-format
;;; code list for a single function. Must be called from within
;;; COMPILE-ONE-LAMBDA, as it depends on assorted specials set up there.
(defun make-fasl ()
(let* ((byte-code nil)
(tag-values nil)
(tag-refs nil)
(constants-list (append entry-points constants-list)))
(translate)
(adjust-long-branches)
(replace-tags)
(replace-catch-tags)
(if *clc-fasl-stream* (dump-fasl-code))
(if *compile-to-lisp* (dump-to-lisp) nil)))
;;; Dump-to-Lisp returns a compiled code object for the current
;;; function. Must be called from within Make-Fasl.
(defun dump-to-lisp ()
(let* ((nconstants (length constants-list))
(fun-length (+ 5 nconstants))
(function (%sp-alloc-function fun-length))
(code-length (length byte-code))
(code (%sp-alloc-u-vector code-length 3)))
(%sp-header-set function 0 (if (eq function-type 'fexpr)
(%sp-logdpb 1 1 27 nconstants)
nconstants))
(%sp-header-set function 1 code)
(do ((bytes byte-code (cdr bytes))
(index 0 (1+ index)))
((null bytes))
(%sp-svset code index (car bytes)))
(%sp-header-set function 2
(if rest-arg-present
(%sp-logdpb
1 1 27 (+ (%sp-lsh nlocals 16) (%sp-lsh max-args 8) min-args))
(+ (%sp-lsh nlocals 16) (%sp-lsh max-args 8) min-args)))
(%sp-header-set function 3 function-name)
(%sp-header-set function 4 current-arglist)
(do ((constants constants-list (cdr constants))
(index 5 (1+ index)))
((= index fun-length))
(%sp-header-set function index (car constants)))
function))
;;; Translate works on LAP-CODE and from it produces BYTE-CODE, a list
;;; containing the numeric byte-codes, and TAG-VALUES, a list of TAG-POSITION
;;; pairs. Branch destinations are represented in the BYTE-CODE list by items
;;; of the form (TAG LONGP REF-LOCATION). These items also are kept on the
;;; TAG-REFS list. They are destructively modified as long-branches are
;;; detected. LONGP is non-null if the branch is a long one. Once a branch
;;; is made long, it never becomes short again. REF-LOCATION is the PC of
;;; the instruction following the branch and its args and tags.
(defun translate ()
(do ((l (cdr lap-code) (cdr l))
(nbytes 0)
(inst-size 0 0)
(i))
((null l)
(setq tag-values (nreverse tag-values))
(setq byte-code (nreverse byte-code))
(setq tag-refs (nreverse tag-refs)))
(setq i (car l))
(cond ((null i))
((tagp i)
(push (cons i nbytes) tag-values))
((eq (opcode i) 'comment))
(t
(setq inst-size (translate-inst i))
(setq nbytes (+ nbytes inst-size))))))
;;; Given an instruction in list form, put out the proper bytes to
;;; the BYTE-CODE list and return the number of bytes used.
(defun translate-inst (i)
(if (memq (car i) '(branch branch-null branch-not-null branch-save-not-null))
(progn
(push-byte (car i))
(push-byte (list (cadr i) nil (+ nbytes 2)))
(push (car byte-code) tag-refs)
2)
(let* ((address (cadr i))
(offsetted (listp address))
(kind (if offsetted (car address) address))
(offset (if offsetted (cadr address)))
(count 0))
(case kind
(short-const
(setq kind (if (< offset 0) 'nsic 'psic)))
(constant
(setq offset (+ 1 offset (- max-args min-args)))
(setq kind (if (> offset 255) 'longc 'c)))
(special
(setq offset (+ 1 offset (- max-args min-args)))
(setq kind (if (> offset 255) 'longs 's)))
(arg
(setq kind (if (> offset 255) 'longal 'al)))
(local
(setq offset (+ offset max-args (if rest-arg-present 1 0)))
(setq kind (if (> offset 255) 'longal 'al))))
(let* ((instr (if (eq kind 'stack)
(car i)
(cdr (assq kind (get (car i) '%instruction-class)))))
(tinstr)
(opcode))
(cond ((null instr)
;; If there's no KIND form of this instruction, simulate it.
(let ((type (get (car i) '%instruction-type)))
(when (memq type '(read read-modify-write))
(incf count (translate-inst `(push ,address))))
(incf count (translate-inst `(,(car i) stack)))
(when (memq type '(write read-modify-write))
(incf count (translate-inst `(pop ,address))))))
(t
(if (atom instr)
(setq opcode (get instr '%instruction-opcode))
(if (setq tinstr (cdr (assq offset instr)))
(setq instr tinstr
opcode (get instr '%instruction-opcode)
offset nil)
(setq instr (cdar instr)
opcode (get instr '%instruction-opcode))))
(unless opcode
(error "~S is an illegal instruction/addressing mode combo."
i))
(push-byte (car opcode))
(incf count)
(when (cadr opcode)
(push-byte (cadr opcode))
(incf count))
(when offset
(push-byte (logand offset 255))
(incf count)
(when (> offset 255)
(push-byte (ash offset -8))
(incf count))))))
count)))
;;;; BRANCH ADDRESS ADJUSTMENT
;;; Make adjustment passes until a pass completes with no mods.
(defun adjust-long-branches ()
(do ((modified t))
((not modified))
(setq modified nil)
;; Scan tag-refs list looking for new long branches.
(do ((tr tag-refs (cdr tr))
(refloc))
((null tr))
(cond
;; If already long, do nothing.
((cadr (car tr)))
;; If short offset, do nothing.
((<= -248
(- (cdr (assq (car (car tr)) tag-values)) (caddr (car tr)))
248))
;; New long branch. Mark it long, adjust reference locs, tags.
(t (setq refloc (caddr (car tr)))
(rplaca (cdr (car tr)) t)
(do ((trest tr (cdr trest)))
((null trest))
(rplaca (cddr (car trest)) (+ 2 (caddr (car trest)))))
(do ((tv tag-values (cdr tv)))
((null tv))
(or (< (cdr (car tv)) refloc)
(rplacd (car tv) (+ 2 (cdr (car tv))))))
(setq modified t)
(return nil))))))
;;; Tag references are now right. Go through BYTE-CODE and replace them
;;; with proper offset bytes. Also modify the branch instructions if the
;;; branch is long.
(defun replace-tags ()
(do ((bc byte-code (cdr bc))
(last-branch-inst)
(current)
(destination)
(offset))
((null bc))
(cond ((numberp (car bc)))
((symbolp (car bc))
(setq last-branch-inst bc))
((cadr (car bc))
;; Long branches are 2 bytes, so insert the 2 byte opcode
;; into the list along with the branch offset.
(setq current (caddar bc))
(setq destination (cdr (assq (caar bc) tag-values)))
(setq offset (- destination current))
(let ((opcode
(get (cdr (assq
(car last-branch-inst)
(if (< offset 0)
'((branch . long-branch-backward)
(branch-null . long-branch-null-backward)
(branch-not-null
. long-branch-not-null-backward)
(branch-save-not-null
. long-branch-save-not-null-backward))
'((branch . long-branch-forward)
(branch-null . long-branch-null-forward)
(branch-not-null
. long-branch-not-null-forward)
(branch-save-not-null
. long-branch-save-not-null-backward)))))
'%instruction-opcode)))
(rplaca last-branch-inst (car opcode))
(rplacd last-branch-inst (cons (cadr opcode) (cdr last-branch-inst)))
(let ((bpc (logand destination 7))
(qword (abs (- (logand destination (lognot 7))
(- (logand current (lognot 7))
(if (= (logand current 7) 0)
8
0))))))
(rplaca bc (logior bpc (logand qword 255)))
(rplacd bc (cons (ash qword -8) (cdr bc))))))
(t
(setq current (caddar bc))
(setq destination (cdr (assq (caar bc) tag-values)))
(setq offset (- destination current))
(rplaca last-branch-inst
(car (get (cdr (assq
(car last-branch-inst)
(if (< offset 0)
'((branch . branch-backward)
(branch-null . branch-null-backward)
(branch-not-null
. branch-not-null-backward)
(branch-save-not-null
. branch-save-not-null-backward))
'((branch . branch-forward)
(branch-null . branch-null-forward)
(branch-not-null
. branch-not-null-forward)
(branch-save-not-null
. branch-save-not-null-forward)))))
'%instruction-opcode)))
(let ((bpc (logand destination 7))
(qword (abs (- (logand destination (lognot 7))
(- (logand current (lognot 7))
(if (= (logand current 7) 0)
8
0))))))
(rplaca bc (logior bpc (logand qword 255))))))))
;;; Replace catch tags in constants list.
(defun replace-catch-tags ()
(do ((cl constants-list (cdr cl)))
((null cl))
(and (listp (car cl))
(eq (caar cl) '**tag**)
(let* ((offset (cdr (assq (cadar cl) tag-values)))
(bpc (logand offset 7))
(word (logand offset (lognot 7))))
(rplaca cl (logior (ash bpc 16) (+ (ash word -1) 4)))))))
;;; Dump out assembled function in FASL format.
;;; This must be called from within MAKE-FASL.
(defun dump-fasl-code ()
(case function-type
((expr fexpr)
(dump-symbol function-name)
(dump-function-object)
(dump-fop 'fop-fset))
(macro
(dump-symbol function-name)
(dump-symbol 'macro)
(dump-function-object)
(dump-fop 'fop-list*)
(quick-dump-number 1 1)
(dump-fop 'fop-fset))
(one-shot
(dump-function-object)
(dump-fop 'fop-funcall-for-effect)
(dump-byte 0))
(t (error "Unknown function type: ~S" function-type)))
(dump-fop 'fop-verify-empty-stack))
;;; Dump a single function object in FASL format so it ends up on FASL stack.
(defun dump-function-object ()
(let ((nconstants (length constants-list))
(nunboxed (length byte-code)))
;; First word of boxed function object:
;; Bits 0-14 number of symbols and constants.
;; Bits 15-26 unused.
;; Bit 27 is 0 if all args are evaled, 1 if a fexpr.
(dump-fop 'fop-word-integer)
(quick-dump-number
(if (eq function-type 'fexpr)
(%sp-logdpb 1 1 27 nconstants)
nconstants)
4)
;; Second, place holder for code vector.
(dump-fop 'fop-misc-trap)
;; Third word:
;; Bits 0-7 minumum number of args.
;; Bits 8-15 maximum number of args.
;; Bits 16-26 number of local vars allocated on stack.
;; Bit 27 is 0 if no &rest arg, 1 if &rest arg is to be used.
(dump-fop 'fop-word-integer)
(quick-dump-number
(if rest-arg-present
(%sp-logdpb
1 1 27 (+ (%sp-lsh nlocals 16) (%sp-lsh max-args 8) min-args))
(+ (%sp-lsh nlocals 16) (%sp-lsh max-args 8) min-args))
4)
;; Fourth, the function name.
(dump-symbol function-name)
;; Fifth, argument vector.
(dump-object current-arglist)
;; Now dump constants in order.
(mapc #'dump-object constants-list)
;; Make this a function object.
(cond ((and (< nconstants 250) (< nunboxed 65536))
(dump-fop 'fop-small-code)
(dump-byte (+ nconstants 5))
(quick-dump-number nunboxed 2))
(t (dump-fop 'fop-code)
(quick-dump-number (+ nconstants 5) 4)
(quick-dump-number nunboxed 4)))
;; Dump code bytes.
(do ((bytes byte-code (cdr bytes)))
((null bytes))
(dump-byte (car bytes)))))
;;;; FASLOAD DUMPING FUNCTIONS
;;; Dump out number NUM as NBYTES bytes.
(defun quick-dump-number (num nbytes)
(do ((n num (ash n -8.))
(i nbytes (1- i)))
((= i 0))
(dump-byte (logand n #o377))))
;;; Dump any sort of object, according to its type.
(defun dump-object (x)
(cond ((null x) (dump-fop 'fop-empty-list))
((eq x t) (dump-fop 'fop-truth))
((symbolp x) (dump-symbol x))
((integerp x) (dump-integer x))
((stringp x) (dump-string x))
((vectorp x) (dump-vector x))
((characterp x) (dump-character x))
((ratiop x) (dump-ratio x))
((short-floatp x) (dump-short-float x))
((single-floatp x) (dump-short-float x))
((double-floatp x) (dump-long-float x))
((long-floatp x) (dump-long-float x))
((listp x) (dump-list x))
(t (error "Compiler bug. Unknown object type to assembler: ~S" x))))
;;; Dump a ratio
(defun dump-ratio (x)
(dump-object (numerator x))
(dump-object (denominator x))
(dump-fop 'fop-ratio))
;;;
;;; These two are almost exactly alike, and could easily be the same function.
(defun dump-short-float (x)
(multiple-value-bind (f exponent sign) (decode-float x)
(let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
(dump-fop 'fop-float)
(dump-byte (1+ (integer-length exponent)))
(dump-byte exponent)
(dump-byte (1+ (integer-length mantissa)))
(quick-dump-number mantissa (compute-bytes mantissa)))))
;;; For long-floats we're careful that the dumped mantissa actually
;;; has 63 significant bits, so the fasloader can recognize it as such.
(defun dump-long-float (x)
(multiple-value-bind (f exponent sign) (decode-float x)
(let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
(dump-fop 'fop-float)
(dump-byte (1+ (integer-length exponent)))
(quick-dump-number exponent (compute-bytes exponent))
(dump-byte (1+ (integer-length mantissa)))
(quick-dump-number mantissa (compute-bytes mantissa)))))
;;; Dump a symbol S.
(defun dump-symbol (s)
(let ((number (get s 'fop-table-index)))
(if number
;; Symbol is already in the table. Just dump the index.
(if (< number 256)
(progn (dump-fop 'fop-byte-push)
(dump-byte number))
(progn (dump-fop 'fop-push)
(quick-dump-number number 4)))
;; Got to dump the symbol and put it into the table.
(let* ((pname (symbol-name s))
(pname-length (length pname))
(pkg (symbol-package s)))
(cond ((null pkg)
;; Symbol is uninterned.
(if (< pname-length 256)
(progn (dump-fop 'fop-uninterned-small-symbol-save)
(dump-byte pname-length))
(progn (dump-fop 'fop-uninterned-symbol-save)
(quick-dump-number pname-length 4))))
((eq pkg *package*)
;; Symbol is in current default package. Just dump it.
(if (< pname-length 256)
(progn (dump-fop 'fop-small-symbol-save)
(dump-byte pname-length))
(progn (dump-fop 'fop-symbol-save)
(quick-dump-number pname-length 4))))
((eq pkg *lisp-package*)
(if (< pname-length 256)
(progn (dump-fop 'fop-lisp-small-symbol-save)
(dump-byte pname-length))
(progn (dump-fop 'fop-lisp-symbol-save)
(quick-dump-number pname-length 4))))
((eq pkg *keyword-package*)
;; Symbol is in current default package. Just dump it.
(if (< pname-length 256)
(progn (dump-fop 'fop-keyword-small-symbol-save)
(dump-byte pname-length))
(progn (dump-fop 'fop-keyword-symbol-save)
(quick-dump-number pname-length 4))))
(t
;; We have to dump this symbol with a package specifier.
(let ((entry (assq pkg fop-table-package-list)))
;; Put the package into the table unless it's already there.
(unless entry
(dump-string (package-name pkg))
(dump-fop 'fop-package)
(dump-fop 'fop-pop)
(setq entry (cons pkg fop-table-counter))
(push entry fop-table-package-list)
(incf fop-table-counter))
(setq entry (cdr entry))
(if (< entry 256)
(if (< pname-length 256)
(progn (dump-fop
'fop-small-symbol-in-byte-package-save)
(dump-byte entry)
(dump-byte pname-length))
(progn (dump-fop 'fop-symbol-in-byte-package-save)
(dump-byte entry)
(quick-dump-number pname-length 4)))
(if (< pname-length 256)
(progn (dump-fop 'fop-small-symbol-in-package-save)
(quick-dump-number entry 4)
(dump-byte pname-length))
(progn (dump-fop 'fop-symbol-in-package-save)
(quick-dump-number entry 4)
(quick-dump-number pname-length 4)))))))
;; Finish dumping the symbol and put it in table.
(do ((index 0 (1+ index)))
((= index pname-length))
(dump-byte (char-code (char pname index))))
(%put s 'fop-table-index fop-table-counter)
(push s fop-table-symbol-list)
(setq fop-table-counter (1+ fop-table-counter))))))
;;; Dumper for lists.
(defun dump-list (list)
(cond ((null list) (dump-fop 'fop-empty-list))
(t (do ((l list (cdr l))
(n 0 (1+ n)))
((atom l)
(cond ((null l)
(terminate-undotted-list n))
(t (dump-object l)
(terminate-dotted-list n))))
(dump-object (car l))))))
(defun terminate-dotted-list (n)
(case n
(1 (dump-fop 'fop-list*-1))
(2 (dump-fop 'fop-list*-2))
(3 (dump-fop 'fop-list*-3))
(4 (dump-fop 'fop-list*-4))
(5 (dump-fop 'fop-list*-5))
(6 (dump-fop 'fop-list*-6))
(7 (dump-fop 'fop-list*-7))
(8 (dump-fop 'fop-list*-8))
(T (do ((nn n (- nn 255)))
((< nn 256)
(dump-fop 'fop-list*)
(dump-byte nn))
(dump-fop 'fop-list*)
(dump-byte 255)))))
;;; If N > 255, must build list with one list operator, then list* operators.
(defun terminate-undotted-list (n)
(case n
(1 (dump-fop 'fop-list-1))
(2 (dump-fop 'fop-list-2))
(3 (dump-fop 'fop-list-3))
(4 (dump-fop 'fop-list-4))
(5 (dump-fop 'fop-list-5))
(6 (dump-fop 'fop-list-6))
(7 (dump-fop 'fop-list-7))
(8 (dump-fop 'fop-list-8))
(T (cond ((< n 256)
(dump-fop 'fop-list)
(dump-byte n))
(t (dump-fop 'fop-list)
(dump-byte 255)
(do ((nn (- n 255) (- nn 255)))
((< nn 256)
(dump-fop 'fop-list*)
(dump-byte nn))
(dump-fop 'fop-list*)
(dump-byte 255)))))))
;;; Dump a vector.
;;; Named B-vectors get their subtype field set at load time.
(defun dump-vector (obj)
(cond ((= (%sp-get-vector-subtype obj) 1)
(dump-object '%sp-set-vector-subtype)
(dump-object 'quote)
(normal-dump-vector obj)
(dump-fop 'fop-list-2)
(dump-object 1)
(dump-fop 'fop-list-3)
(dump-fop 'fop-eval))
(t
(normal-dump-vector obj))))
(defun normal-dump-vector (v)
(do ((index 0 (1+ index))
(length (length v)))
((= index length)
(cond ((< length 256)
(dump-fop 'fop-small-vector)
(dump-byte length))
(t (dump-fop 'fop-vector)
(quick-dump-number length 4))))
(dump-object (aref v index))))
;;; Dump a string.
(defun dump-string (s)
(let ((length (length s)))
(cond ((< length 256)
(dump-fop 'fop-small-string)
(dump-byte length))
(t
(dump-fop 'fop-string)
(quick-dump-number length 4)))
(do ((index 0 (1+ index)))
((= index length))
(dump-byte (char-code (char s index))))))
;;; Dump a character.
(defun dump-character (ch)
(cond
((string-char-p ch)
(dump-fop 'fop-short-character)
(dump-byte (char-code ch)))
(t
(dump-fop 'fop-character)
(dump-byte (char-code ch))
(dump-byte (char-bits ch))
(dump-byte (char-font ch)))))
;;; Dump an integer.
(defun dump-integer (n)
(let* ((nbytes (compute-bytes n)))
(cond ((= nbytes 1) (dump-fop 'fop-byte-integer) (dump-byte n))
((< nbytes 5) (dump-fop 'fop-word-integer) (quick-dump-number n 4))
((< nbytes 256)
(dump-fop 'fop-small-integer)
(dump-byte nbytes)
(quick-dump-number n nbytes))
(t (dump-fop 'fop-integer)
(quick-dump-number nbytes 4)
(quick-dump-number n nbytes)))))
;;; Compute how many bytes it will take to represent signed integer N.
(defun compute-bytes (n)
(truncate (+ (integer-length n) 8) 8))