Skip to content
Snippets Groups Projects
Commit 6a9d4112 authored by cvs2git's avatar cvs2git
Browse files

This commit was manufactured by cvs2svn to create branch 'new_constraint'.

parent 30f1bd52
No related branches found
No related tags found
No related merge requests found
Showing
with 0 additions and 13267 deletions
;;; -*- Log: clc.log; Package: Compiler -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; 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. This file deals with turning
;;; LAP code into binary code and dumping the results in the right places.
;;; There also ulilities for dealing with the various output files.
;;;
;;; Written by many hands: Joe Ginder, Scott Fahlman, Dave Dill,
;;; Walter van Roggen, and Skef Wholey.
;;; Currently maintained by Scott Fahlman.
(in-package 'compiler :use '(system))
(import '(lisp::%fasl-code-format))
;;; Version number.
(defparameter assembler-version "2.0")
(defparameter target-fasl-code-format 3)
(proclaim '(special compiler-version target-machine target-system
*compile-to-lisp* *lisp-package* *keyword-package*))
(defvar function-name nil
"Holds a symbol that names the function currently being compiled,
or nil if between functions.")
;;; Output streams:
;;; If a stream is NIL, don't produce that kind of output.
(defvar *clc-fasl-stream* nil)
(defvar *clc-lap-stream* nil)
(defvar *clc-err-stream* nil)
;;; Stuff we keep track of for the error log:
(defvar functions-with-errors nil
"A list of all functions that did not compile properly due to errors in
the code.")
(defvar error-count 0
"The number of errors generated during this compilation.")
(defvar warning-count 0
"The number of warnings generated during this compilation.")
(defvar unknown-functions nil
"List of functions called but not yet seen and not built-in. The user
is informed of any function still on this list at the end of a file
compilation.")
(defvar unknown-free-vars nil
"A list of all variables referenced free in the compilation, but not
bound or declared special anywhere. These are assumed to be special
variables, but are listed in a warning message at the end of the
compilation.")
(defvar *verbose* t
"If nil, only true error messages and warnings go to the error stream.
If non-null, prints a message as each function is compiled.")
(defvar *compile-to-lisp* nil
"If non-null, stuff compiled definitions into the compiler's own Lisp
environment.")
(defvar *clc-input-stream* nil)
(defvar *input-filename* nil "Truename of file being compiled.")
(defvar *compiler-is-reading* nil
"This is true only if we are actually doing a read from *clc-input-stream*.
#, (in the reader) looks at this.")
;;; The Line-Length of the lap stream...
(defvar *lap-line-length*)
;;; The defined-from string for functions defined in the current source file:
(defvar *current-defined-from*)
;;;; Error Reporting:
;;; CLC-MUMBLE is just a format print to the error stream.
(defun clc-mumble (string &rest args)
(when *clc-err-stream*
(apply #'format *clc-err-stream* string args)))
;;; A COMMENT is something the user might like to know, but that will
;;; probably not affect the correctness of his code.
(defun clc-comment (string &rest args)
(when *clc-err-stream*
(if (or (not function-name) (eq function-name 'lisp::top-level-form))
(format *clc-err-stream* "Comment between functions:~% ")
(format *clc-err-stream* "Comment in ~S:~% " function-name))
(apply #'format *clc-err-stream* string args)
(terpri *clc-err-stream*)))
;;; A WARNING is something suspicious in the user's code that probably
;;; signals some form of lossage, but that may be ignored if the user
;;; knows what he is doing.
(defun clc-warning (string &rest args)
(when *clc-err-stream*
(incf warning-count)
(if (or (not function-name) (eq function-name 'lisp::top-level-form))
(format *clc-err-stream* "Warning between functions:~% ")
(format *clc-err-stream* "Warning in ~S:~% " function-name))
(apply #'format *clc-err-stream* string args)
(terpri *clc-err-stream*)))
;;; An ERROR is a problem in the user's code that will definitely cause some
;;; lossage. The compiler attempts to go on with the compilation so that
;;; as many errors as possible can be caught per compilation.
(defun clc-error (string &rest args)
(when *clc-err-stream*
(incf error-count)
(cond ((or (not function-name) (eq function-name 'lisp::top-level-form))
(format *clc-err-stream* "Error between functions:~% ")
(pushnew function-name functions-with-errors))
(t
(format *clc-err-stream* "Error in ~S:~% " function-name)))
(apply #'format *clc-err-stream* string args)
(terpri *clc-err-stream*)))
;;; Keep the internal real and run times in these vars so that we can report
;;; the elapsed time.
(defvar *start-real-time*)
(defvar *start-run-time*)
;;; Start-Assembly -- Internal
;;;
;;; This function is called before assembling each batch of stuff. It
;;; writes out the fasl file header and does other random stuff. It is
;;; assumed that all the streams are initialized at this point.
;;;
(defun start-assembly ()
(let* ((host (machine-instance))
(now (get-universal-time))
(now-string (universal-time-to-string now))
(in-string (if *input-filename* (namestring *input-filename*)))
(then (if *input-filename*
(file-write-date *input-filename*)))
(then-string (if then (universal-time-to-string then)))
(where (cond ((not *clc-input-stream*)
(format nil "Lisp on ~A, machine ~A" now-string host))
(in-string
(format nil "~A ~A" in-string now-string))
((not then)
(format nil "~S on ~A, machine ~A" *clc-input-stream*
now-string host))
(t
(format nil "~A ~A" in-string then-string)))))
;; Set the defined-from string:
(setq *current-defined-from* (format nil "~A ~D" where (or then now)))
(when *input-filename*
(setq *start-real-time* (get-internal-real-time))
(setq *start-run-time* (get-internal-run-time))
(clc-mumble "Error output from ~A.~@
Compiled on ~A by CLC version ~A.~2%"
where now-string compiler-version))
(when *clc-lap-stream*
(setq *lap-line-length* (or (lisp::line-length *clc-lap-stream*) 80))
(format *clc-lap-stream*
"~:[Unreadble~;Readable~] LAP output from ~A.~@
Compiled on ~A by CLC version ~A.~%"
*print-readable-lap* where now-string compiler-version))
(when *clc-fasl-stream*
(format *clc-fasl-stream* "FASL FILE output from ~A~@
Compiled ~A on ~A~@
Compiler ~A, Assembler ~A, Lisp ~A~@
Targeted for ~A/~A, FASL code format ~D~%"
where now-string host compiler-version assembler-version
(lisp-implementation-version) target-machine target-system
c::target-fasl-code-format)
(start-fasl-file))))
;;; Also the ten-dozenth place this is defined...
(defun universal-time-to-string (ut)
(multiple-value-bind (sec min hour day month year)
(decode-universal-time ut)
(format nil "~D-~A-~2,'0D ~D:~2,'0D:~2,'0D"
day (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
"Sep" "Oct" "Nov" "Dec")
(1- month))
(rem year 100)
hour min sec)))
(defun elapsed-time-to-string (it)
(let ((tsec (truncate it internal-time-units-per-second)))
(multiple-value-bind (tmin sec)
(truncate tsec 60)
(multiple-value-bind (thr min)
(truncate tmin 60)
(format nil "~D:~2,'0D:~2,'0D" thr min sec)))))
;;; Finish-Assembly -- Internal
;;;
;;;
(defun finish-assembly ()
(when *clc-fasl-stream* (terminate-fasl-file))
;; All done. Let the post-mortems begin.
(when *input-filename*
(clc-mumble "~%Finished compilation of file ~S.~%"
(namestring *input-filename*))
(clc-mumble "~S Errors, ~S Warnings.~%" error-count warning-count)
(clc-mumble "Elapsed time ~A, run time ~A.~2%"
(elapsed-time-to-string (- (get-internal-real-time)
*start-real-time*))
(elapsed-time-to-string (- (get-internal-run-time)
*start-run-time*))))
(when functions-with-errors
(clc-mumble "Errors were detected in the following functions:~% ~S~%"
(nreverse functions-with-errors)))
(when unknown-functions
(clc-mumble
"These symbols were called as functions but not declared or defined:~% ~S~%"
(nreverse unknown-functions)))
(do* ((p NIL)
(l unknown-free-vars (cdr l))
(a (car l) (car l)))
((null l))
(if (get a 'globally-special-in-compiler)
(cond (p (rplacd p (cdr l))
(setq l p))
(T (setq unknown-free-vars (cdr l))
(setq p NIL)))
(setq p l)))
(when unknown-free-vars
(clc-mumble
"The following variables, assumed to be special, are referenced~@
but never declared:~% ~S~%"
(nreverse unknown-free-vars))))
;;;; Fasl dumping stuff:
;;; 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)
;;; When we dump lists and strings, we look for them in this hashtable.
;;; If we find what we are looking for, we just push the thing from the
;;; table. If it isn't there, we dump the object and then enter it.
(defvar *table-table* (make-hash-table :test #'equal))
;;; If true, then we must dump stuff so that it neither adds to nor refers
;;; the table. This is used by the forms which need to be available
;;; at cold load time.
(defvar *hands-off-table* nil)
;;; 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*
:start 0 :end *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 'lisp::fop-code)))
(if (null val)
(error "Compiler bug: ~S not a legal fasload operator." fs)
(dump-byte val))))
(defmacro dump-fop* (n byte-fop word-fop)
`(cond ((< ,n 256)
(dump-fop ',byte-fop)
(dump-byte ,n))
(t
(dump-fop ',word-fop)
(quick-dump-number ,n 4))))
;;; Dump out number NUM as BYTES bytes.
(defun quick-dump-number (num bytes)
(do ((n num (ash n -8))
(i bytes (1- i)))
((= i 0))
(dump-byte (logand n #o377))))
;;; Start-Fasl-File -- Internal
;;;
;;; Set up fasdumper state and finish off the header. The "FASL FILE"
;;; header should already be written. Called by Start-Assembly.
;;;
(defun start-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) 'lisp::fop-table-index))))
;; Clear the package alist.
(setq fop-table-package-list nil)
;; And the table hashtable.
(clrhash *table-table*)
;; Reset the dump-byte buffer
(setq *dump-byte-index* 0)
;; Print header stuff.
(dump-byte 255)
;; Perq code format.
(dump-fop 'lisp::fop-code-format)
(dump-byte c::target-fasl-code-format))
;;; Terminate-Fasl-File -- Internal
;;;
;;; Finish off the current fasl group and clean up. Called from
;;; Finish-Assembly.
;;;
(defun terminate-fasl-file ()
(dump-fop 'lisp::fop-verify-empty-stack)
(dump-fop 'lisp::fop-verify-table-size)
(quick-dump-number fop-table-counter 4)
(dump-fop 'lisp::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) 'lisp::fop-table-index)))
;;; Fasl-Dump-Cold-Load-Form -- Internal
;;;
;;; Similar to fasl-dump-form, except that the form is to be evaluated
;;; at cold load time when in cold load. This is used to dump package
;;; frobbing forms.
;;;
(defun fasl-dump-cold-load-form (form)
(dump-fop 'lisp::fop-normal-load)
(let ((*hands-off-table* t))
(dump-object form))
(dump-fop 'lisp::fop-eval-for-effect)
(dump-fop 'lisp::fop-maybe-cold-load))
;;; Dump-Object -- Internal
;;;
;;; Dump an object of any type. This function dispatches to the correct
;;; type-specific dumping function. Table entry and lookup for non-immediate
;;; objects other than lists and symbols is done here.
;;;
(defun dump-object (x)
(cond
((listp x)
(cond ((null x)
(dump-fop 'lisp::fop-empty-list))
((eq (car x) '%eval-at-load-time)
(load-time-eval x))
(t
(dump-list x))))
((symbolp x)
(if (eq x t)
(dump-fop 'lisp::fop-truth)
(dump-symbol x)))
((fixnump x) (dump-integer x))
((characterp x) (dump-character x))
((typep x 'short-float) (dump-short-float x))
(t
;;
;; Look for it in the table; if it is there, push it, otherwise
;; dump it.
(let ((index (gethash x *table-table*)))
(cond
((and index (not *hands-off-table*))
(dump-fop* index lisp::fop-byte-push lisp::fop-push))
(t
(typecase x
(vector
(cond ((stringp x) (dump-string x))
((subtypep (array-element-type x) '(unsigned-byte 16))
(dump-i-vector x))
(t
(dump-vector x))))
(array (dump-array x))
(number
(etypecase x
(ratio (dump-ratio x))
(complex (dump-complex x))
; (single-float (dump-single-float x))
(long-float (dump-long-float x))
(integer (dump-integer x))))
(compiled-function (dump-function x))
(t
(clc-error "This object cannot be dumped into a fasl file:~% ~S" x)
(dump-object nil)))
;;
;; If wasn't in the table, put it there...
(unless *hands-off-table*
(dump-fop 'lisp::fop-pop)
(dump-fop* fop-table-counter lisp::fop-byte-push lisp::fop-push)
(setf (gethash x *table-table*) fop-table-counter)
(incf fop-table-counter))))))))
;;;; Number Dumping:
;;; Dump a ratio
(defun dump-ratio (x)
(dump-object (numerator x))
(dump-object (denominator x))
(dump-fop 'lisp::fop-ratio))
;;; Or a complex...
(defun dump-complex (x)
(dump-object (realpart x))
(dump-object (imagpart x))
(dump-fop 'lisp::fop-complex))
;;; Dump an integer.
(defun dump-integer (n)
(let* ((bytes (compute-bytes n)))
(cond ((= bytes 1)
(dump-fop 'lisp::fop-byte-integer)
(dump-byte n))
((< bytes 5)
(dump-fop 'lisp::fop-word-integer)
(quick-dump-number n 4))
((< bytes 256)
(dump-fop 'lisp::fop-small-integer)
(dump-byte bytes)
(quick-dump-number n bytes))
(t (dump-fop 'lisp::fop-integer)
(quick-dump-number bytes 4)
(quick-dump-number n bytes)))))
;;; Compute how many bytes it will take to represent signed integer N.
(defun compute-bytes (n)
(truncate (+ (integer-length n) 8) 8))
;;;
;;; 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 'lisp::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)))))
#|
(defun dump-single-float (x)
(multiple-value-bind (f exponent sign) (decode-float x)
(let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
(dump-fop 'lisp::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 'lisp::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)))))
;;;; Symbol Dumping:
(defun dump-symbol (s)
(let ((number (get s 'lisp::fop-table-index)))
(if (and number (not *hands-off-table*))
;; Symbol is already in the table. Just dump the index.
(dump-fop* number lisp::fop-byte-push lisp::fop-push)
;; 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.
(dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
lisp::fop-uninterned-symbol-save))
((eq pkg *package*)
;; Symbol is in current default package. Just dump it.
(dump-fop* pname-length lisp::fop-small-symbol-save
lisp::fop-symbol-save))
((eq pkg *lisp-package*)
(dump-fop* pname-length lisp::fop-lisp-small-symbol-save
lisp::fop-lisp-symbol-save))
((eq pkg *keyword-package*)
;; Symbol is in current default package. Just dump it.
(dump-fop* pname-length lisp::fop-keyword-small-symbol-save
lisp::fop-keyword-symbol-save))
(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
(unless *hands-off-table*
(dump-fop 'lisp::fop-normal-load))
(dump-string (package-name pkg))
(dump-fop 'lisp::fop-package)
(dump-fop 'lisp::fop-pop)
(unless *hands-off-table*
(dump-fop 'lisp::fop-maybe-cold-load))
(setq entry (cons pkg fop-table-counter))
(push entry fop-table-package-list)
(incf fop-table-counter))
(setq entry (cdr entry))
(cond
((< pname-length 256)
(dump-fop* entry
lisp::fop-small-symbol-in-byte-package-save
lisp::fop-small-symbol-in-package-save)
(dump-byte pname-length))
(t
(dump-fop* entry
lisp::fop-symbol-in-byte-package-save
lisp::fop-symbol-in-package-save)
(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 (schar pname index))))
(unless *hands-off-table*
(setf (get s 'lisp::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)
(if (null list)
(dump-fop 'lisp::fop-empty-list)
(let ((index (gethash list *table-table*)))
(cond ((and index (not *hands-off-table*))
(dump-fop* index lisp::fop-byte-push lisp::fop-push))
(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)))
(unless *hands-off-table*
(dump-fop 'lisp::fop-pop)
(dump-fop* fop-table-counter lisp::fop-byte-push
lisp::fop-push)
(setf (gethash list *table-table*) fop-table-counter)
(incf fop-table-counter)))))))
(defun terminate-dotted-list (n)
(case n
(1 (dump-fop 'lisp::fop-list*-1))
(2 (dump-fop 'lisp::fop-list*-2))
(3 (dump-fop 'lisp::fop-list*-3))
(4 (dump-fop 'lisp::fop-list*-4))
(5 (dump-fop 'lisp::fop-list*-5))
(6 (dump-fop 'lisp::fop-list*-6))
(7 (dump-fop 'lisp::fop-list*-7))
(8 (dump-fop 'lisp::fop-list*-8))
(T (do ((nn n (- nn 255)))
((< nn 256)
(dump-fop 'lisp::fop-list*)
(dump-byte nn))
(dump-fop 'lisp::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 'lisp::fop-list-1))
(2 (dump-fop 'lisp::fop-list-2))
(3 (dump-fop 'lisp::fop-list-3))
(4 (dump-fop 'lisp::fop-list-4))
(5 (dump-fop 'lisp::fop-list-5))
(6 (dump-fop 'lisp::fop-list-6))
(7 (dump-fop 'lisp::fop-list-7))
(8 (dump-fop 'lisp::fop-list-8))
(T (cond ((< n 256)
(dump-fop 'lisp::fop-list)
(dump-byte n))
(t (dump-fop 'lisp::fop-list)
(dump-byte 255)
(do ((nn (- n 255) (- nn 255)))
((< nn 256)
(dump-fop 'lisp::fop-list*)
(dump-byte nn))
(dump-fop 'lisp::fop-list*)
(dump-byte 255)))))))
;;;; Array dumping:
;;; Named G-vectors get their subtype field set at load time.
(defun dump-vector (obj)
(cond ((and (simple-vector-p obj)
(= (%primitive get-vector-subtype obj)
%g-vector-structure-subtype))
(normal-dump-vector obj)
(dump-fop 'lisp::fop-structure))
(t
(normal-dump-vector obj))))
(defun normal-dump-vector (v)
(do ((index 0 (1+ index))
(length (length v)))
((= index length)
(dump-fop* length lisp::fop-small-vector lisp::fop-vector))
(dump-object (aref v index))))
;;; Dump a string.
(defun dump-string (s)
(let ((length (length s)))
(dump-fop* length lisp::fop-small-string lisp::fop-string)
(dotimes (i length)
(dump-byte (char-code (char s i))))))
;;; Dump-Array -- Internal
;;;
;;; Dump a multi-dimensional array. Someday when we figure out what
;;; a displaced array looks like, we can fix this.
;;;
(defun dump-array (array)
(unless (zerop (%primitive header-ref array %array-displacement-slot))
(clc-error "Attempt to dump an array with a displacement, you lose big.")
(dump-object nil)
(return-from dump-array nil))
(let ((rank (array-rank array)))
(dotimes (i rank)
(dump-integer (array-dimension array i)))
(dump-object (%primitive header-ref array %array-data-slot))
(dump-fop 'lisp::fop-array)
(quick-dump-number rank 4)))
;;; Dump a character.
(defun dump-character (ch)
(cond
((string-char-p ch)
(dump-fop 'lisp::fop-short-character)
(dump-byte (char-code ch)))
(t
(dump-fop 'lisp::fop-character)
(dump-byte (char-code ch))
(dump-byte (char-bits ch))
(dump-byte (char-font ch)))))
This diff is collapsed.
;;; -*- Mode: Lisp; Package: Compiler -*-
;;; **********************************************************************
;;; 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).
;;; **********************************************************************
;;;
;;; The DISASSEMBLE function as described in the Common Lisp manual.
;;;
;;; Written by Don Mathis
;;;
;;;
;;; Modified 11/83 by Robert Rose to put an asterisk before lines
;;; that are branched to.
;;;
;;; Heavily Modified 1/84 to use new instruction set.
;;;
;;; Modified by David B. McDonald to disassemble the Romp instruction
;;; set.
;;;
;;; Hacked by Rob MacLachlan for the interim RT function format. Hopefully
;;; this file will die after the port.
;;;
;;; **********************************************************************
;;;
(in-package 'compiler :use '("LISP" "SYSTEM"))
(export 'lisp::disassemble (find-package 'lisp))
(proclaim '(special romp-4bit-opcode-symbol romp-8bit-opcode-symbol))
;;;; The Main function, DISASSEMBLE
(defun disassemble (function &optional (*standard-output* *standard-output*))
"The argument should be either a function object, a lambda expression, or
a symbol with a function definition. If the relevant function is not a
compiled function, it is first compiled. In any case, the compiled code
is then 'reverse assembled' and printed out in a symbolic format."
(etypecase function
(function
(ecase (%primitive get-vector-subtype function)
((#.%function-entry-subtype #.%function-closure-entry-subtype)
(prin-prelim-info function)
(Output-macro-instructions function (branch-list function)))
(#.%function-closure-subtype
(disassemble (%primitive header-ref function %function-name-slot)))))
(symbol
(disassemble (symbol-function function)))))
;;; PRIN-PRELIM-INFO takes a function object and extracts from it and
;;; prints out the following information:
;;; - The argument list of the function.
;;; - The number of Locals allocated by the function.
;;; - Whether the function does or does not evaluate its arguments.
(defun prin-prelim-info (function)
(format t "~%Disassembly of ~S.~%"
(%primitive header-ref function %function-name-slot))
(format t "~%Its arg list is: ~A.~%"
(%primitive header-ref function %function-entry-arglist-slot)))
;;; OUTPUT-MACRO-INSTRUCTIONS takes a function object and prints out the
;;; corresponding macro. (Not executable macro, just macro that looks good!)
(defun Output-Macro-Instructions (function branches)
(declare (optimize (speed 3) (safety 0)))
(let* ((byte-vector
(%primitive header-ref function %function-code-slot))
(offset
(- (%primitive header-ref function %function-offset-slot)
i-vector-header-size))
(vector-length (length byte-vector)))
(declare (fixnum vector-length))
(do ((i 0))
((= i vector-length))
(declare (fixnum i))
(when (= i offset)
(format t "~&*** Enter here:~%"))
(let* ((opcode (aref byte-vector i))
(symbol (find-symbol-name opcode))
(inst-type (get symbol 'romp-instruction-type)))
(case inst-type
(ji (print-ji-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 2))))
(x (print-x-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 2))))
(ds (print-ds-instruction opcode byte-vector i branches function)
(setq i (the fixnum (+ i 2))))
(r (print-r-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 2))))
(bi (print-bi-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 4))))
(ba (print-ba-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 4))))
(d (setq i (the fixnum
(+ i (the fixnum
(print-d-instruction opcode byte-vector i
branches function ))))))
(T (error "Illegal instruction type: ~A for instruction ~A.~%"
inst-type symbol)))))))
(defun find-symbol-name (opcode)
(declare (fixnum opcode))
(let ((symbol (svref romp-4bit-opcode-symbol (logand (the fixnum (ash opcode -4)) #xFF))))
(if symbol
symbol
(svref romp-8bit-opcode-symbol opcode))))
;;; BRANCH-LIST is very much like output-macro-instructions,
;;; but instead of actually creating all the instructions it just
;;; creates the branch instruction labels. A list of these labels
;;; is returned.
(defun branch-list (function)
(let* ((byte-vector
(%primitive header-ref function %function-code-slot))
(vector-length (length byte-vector))
(branches nil))
(declare (fixnum vector-length))
(do ((i 0))
((>= i vector-length))
(declare (fixnum i))
(let* ((opcode (aref byte-vector i))
(symbol (find-symbol-name opcode))
(inst-type (get symbol 'romp-instruction-type)))
(case inst-type
(ji (push (the fixnum (+ i (the fixnum (sign-extend-ji byte-vector i)))) branches)
(setq i (the fixnum (+ i 2))))
((x ds r) (setq i (the fixnum (+ i 2))))
(bi (push (the fixnum (+ i (the fixnum (sign-extend-bi byte-vector i)))) branches)
(setq i (the fixnum (+ i 4))))
((ba d) (setq i (the fixnum (+ i 4))))
(T (error "Unknown instruction type: ~A, for instruction ~A.~%"
inst-type symbol)))))
branches))
(defun print-ji-instruction (opcode byte-vector index branches)
(declare (fixnum opcode index))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(if (= (logand opcode #x8) 0) "JNB" "JB")
(romp-condition-code (+ 8 (logand opcode #x7)))
`(**address** ,(the fixnum (+ index (the fixnum (sign-extend-ji byte-vector index)))))))
(defun print-x-instruction (opcode byte-vector index branches)
(declare (fixnum opcode index))
(let* ((rega (get-register-name (logand opcode #xF)))
(operand (aref byte-vector (the fixnum (1+ index))))
(regb (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
(regc (get-register-name (logand operand #xF)))
(star (if (memq index branches) "*" " ")))
(declare (fixnum operand))
(if (eq regc 'NL0)
(cond ((and (eq rega 'NL0) (eq regb 'NL0))
(format t "~6D~A (LR NL0 NL0) ; Padding for previous execute instruction.~%"
index star))
(T (format t "~6D~A (LR ~A ~A)~%"
index (if (memq index branches) "*" " ")
rega regb)))
(format t "~6D~A (CAS ~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
rega regb regc))))
(defun print-ds-instruction (opcode byte-vector index branches function)
(declare (fixnum opcode index))
(let* ((symbol (find-symbol-name opcode))
(operand (aref byte-vector (the fixnum (1+ index))))
(rega (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
(regb (get-register-name (logand operand #xF)))
(offset (ash (logand opcode #xF) 2)))
(declare (fixnum offset operand))
(cond ((and (memq symbol '(ls sts))
(memq regb '(ENV CONT)))
(print-special-access symbol rega regb offset function
index branches))
(T (format t "~6D~A (~A ~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
(get-register-name (logand (the fixnum (ash operand -4)) #xF))
(get-register-name (logand operand #xF))
(case symbol
((ls sts) (ash (logand opcode #xF) 2))
((lhs lhas sths) (ash (logand opcode #xF) 1))
(T (logand opcode #xF))))))))
(defun print-r-instruction (opcode byte-vector index branches)
(declare (fixnum index opcode))
(let* ((symbol (find-symbol-name opcode))
(operand (aref byte-vector (the fixnum (1+ index))))
(rega (logand (the fixnum (ash operand -4)) #xF))
(regb (logand operand #xF)))
(declare (fixnum operand))
(cond ((memq symbol '(inc dec lis mftbil mftbiu mttbil mttbiu
ais cis sis clrbl clrbu setbl setbu
sari sari16 sri sri16 srpi srpi16
sli sli16 slpi slpi16))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
(get-register-name rega)
regb))
((memq symbol '(bbr bbrx bnbr bnbrx))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
(romp-condition-code rega)
(get-register-name regb)))
((memq symbol '(mts mfs))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
rega regb))
((memq symbol '(clrsb setsb))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
rega regb))
(T (format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
(get-register-name rega)
(get-register-name regb))))))
(defun print-bi-instruction (opcode byte-vector index branches)
(declare (fixnum index opcode))
(let* ((symbol (find-symbol-name opcode))
(cc (romp-condition-code
(logand (ash (the fixnum (aref byte-vector (the fixnum (1+ index)))) -4) #xF)))
(label (the fixnum (+ index (the fixnum (sign-extend-bi byte-vector index))))))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol) cc `(**address** ,label))))
(defun print-ba-instruction (opcode byte-vector index branches)
(declare (fixnum index opcode))
(let* ((symbol (find-symbol-name opcode))
(operand (the fixnum (logior (ash (the fixnum (aref byte-vector (the fixnum (1+ index)))) 16)
(ash (the fixnum (aref byte-vector (the fixnum (+ index 2)))) 8)
(the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
(miscop (find-miscop-name operand)))
(format t "~6D~A (~A ~A) ; Call miscop ~A.~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
miscop
miscop))
4)
(defun print-d-instruction (opcode byte-vector index branches function)
(declare (fixnum index opcode))
(let* ((symbol (find-symbol-name opcode))
(operand (aref byte-vector (the fixnum (1+ index))))
(rega (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
(regb (get-register-name (logand operand #xF)))
(offset (sign-extend-d byte-vector index)))
(declare (fixnum offset operand))
(cond ((eq symbol 'ci)
(format t"~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
rega offset)
4)
((and (memq symbol '(l st))
(memq regb '(ENV CONT)))
(print-special-access symbol rega regb offset function
index branches)
4)
(T (format t "~6D~A (~A ~A ~A ~A)~A~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
rega regb offset
(if (eq (setq offset (logand offset #xFFFF)) nil-16)
" ; NIL."
(if (eq offset t-16)
" ; T."
"")))
4))))
(defun print-special-access (symbol rega regb offset function index branches)
(declare (fixnum index offset))
(let ((star (if (memq index branches) "*" " "))
(*print-level* 3)
(*print-length* 10))
(cond
((not (eq regb 'ENV))
(format t "~6D~A (~A ~A ~A ~A) ; Stack slot ~D.~%"
index star (symbol-name symbol)
rega regb offset
(ash offset -2)))
((= offset (ash %function-code-slot 2))
(format t "~6D~A (~A ~A ~A ~A) ; Function code.~%"
index star (symbol-name symbol)
rega regb offset))
((= offset (ash %function-offset-slot 2))
(format t "~6D~A (~A ~A ~A ~A) ; Function offset.~%"
index star (symbol-name symbol)
rega regb offset))
(t
(format t "~6D~A (~A ~A ~A ~A) ; Constant: ~S.~%"
index star (symbol-name symbol)
rega regb offset
(%primitive header-ref
(%primitive header-ref function
%function-entry-constants-slot)
(ash (the fixnum
(- offset g-vector-header-size)) -2)))))))
(defun sign-extend-ji (byte-vector index)
(declare (fixnum index))
(let ((byte (aref byte-vector (the fixnum (1+ index)))))
(declare (fixnum byte))
(ash (if (= (logand byte #x80) 0)
byte
(the fixnum (- (the fixnum (1+ (logand (lognot byte) #x7F))))))
1)))
(defun sign-extend-bi (byte-vector index)
(declare (fixnum index))
(let ((int (logior (the fixnum (ash (logand (the fixnum (aref byte-vector (the fixnum (1+ index)))) #xF) 16))
(the fixnum (ash (aref byte-vector (the fixnum (+ index 2))) 8))
(the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
(declare (fixnum int))
(ash (if (= (logand int #x80000) 0)
int
(the fixnum (- (the fixnum (1+ (logand (lognot int) #x7FFFF))))))
1)))
(defun sign-extend-d (byte-vector index)
(declare (fixnum index))
(let ((hword (logior (the fixnum (ash (aref byte-vector (the fixnum (+ index 2))) 8))
(the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
(declare (fixnum hword))
(if (= (logand hword #x8000) 0)
hword
(the fixnum (- (the fixnum (1+ (logand (lognot hword) #xFFFF))))))))
(defun romp-condition-code (cc)
(if (<= 8 cc 16)
(svref '#(pz lt eq gt cz reserved ov tb) (- cc 8))
'??))
(defun get-register-name (reg)
(svref '#(NL0 A0 NL1 A1 A3 A2 SP L0 L1 L2 L3 L4 BS CONT ENV PC) reg))
(defvar miscop-cache NIL)
(defun find-miscop-name (index)
(if (null miscop-cache) (initialize-miscop-cache))
(gethash index miscop-cache))
(defun initialize-miscop-cache ()
(setq miscop-cache (make-hash-table :size 500))
(do-symbols (x (find-package "CLC"))
(let ((v (get x 'lisp::%loaded-address)))
(when v
(setf (gethash v miscop-cache) x))))
(dolist (x lisp::*user-defined-miscops*)
(setf (gethash (get x 'lisp::%loaded-address) miscop-cache) x)))
;;; -*- Mode: Lisp; Package: Compiler -*-
;;; **********************************************************************
;;; 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).
;;; **********************************************************************
(in-package 'compiler)
(export '(asm asm-files) (find-package 'compiler))
(defun asm (f)
(assemble-file (concatenate 'simple-string "miscops:" f ".romp")))
(defun asm-files ()
(asm "abs")
(asm "allocation")
(asm "arith")
(asm "array")
(asm "byte")
(asm "call")
(asm "nlx")
(asm "compare")
(asm "divide")
(asm "gc")
(asm "gcd")
(asm "irrat")
(asm "list")
(asm "logic")
(asm "minus")
(asm "misc")
(asm "multiply")
(asm "negate")
(asm "plus")
(asm "print")
(asm "predicate")
(asm "save")
(asm "stack")
(asm "symbol")
(asm "system")
(asm "truncate"))
This diff is collapsed.
;;; -*- Mode: Lisp; Package: Compiler -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; This file defines the instruction set for the Common Lisp Romp Assembler
;;; used by the compiler.
;;; Written by David B. McDonald.
(in-package 'Compiler)
(defvar romp-4bit-opcode-symbol (make-array 16))
(defvar romp-8bit-opcode-symbol (make-array 256))
;;; Define-Romp-Instruction defines a Romp instruction to the assembler.
;;; It accepts three arguments:
;;; romp-instruction is a symbol whose pname is the name of a Romp instruction
;;; romp-inst-type specifies the underlying type of the Romp instruction.
;;; it must have one of the following values: JI, X, DS, R, BI, BA,
;;; or D.
;;; romp-code specifies the numeric op code for the instruction.
(defmacro Define-Romp-Instruction (romp-instruction romp-inst-type romp-code)
`(progn (setf (get ',romp-instruction 'romp-instruction-type)
',romp-inst-type)
(setf (get ',romp-instruction 'romp-operation-code)
,romp-code)
,(case romp-inst-type
(ji
`(setf (svref romp-4bit-opcode-symbol 0) ',romp-instruction))
((x ds)
`(setf (svref romp-4bit-opcode-symbol ,romp-code) ',romp-instruction))
((r bi ba d)
`(setf (svref romp-8bit-opcode-symbol ,romp-code) ',romp-instruction))
(T
(error "Illegal instruction type: ~A, for instruction ~A (~A).~%"
romp-inst-type romp-instruction romp-code)))))
;;; Define-Romp-Branch defines a Romp branch instruction to the assembler. It
;;; accepts three arguments:
;;; romp-branch is a symbol whose pname is the name of a branch instruction.
;;; romp-instruction is the underlying romp-instruction that should be used
;;; used to implement the branch instruction.
;;; condition-code specifies the bit of the condition code that should be
;;; be tested to implement the branch.
(defmacro Define-Romp-Branch (romp-branch romp-instruction condition-code)
`(progn (setf (get ',romp-branch 'romp-branch-instruction)
',romp-instruction)
(setf (get ',romp-branch 'romp-condition-code)
,condition-code)))
;;; Define-Condition-Code associates the integer code for a particular condition
;;; code bit with a symbol. It accepts a symbol and a value.
(defmacro Define-Condition-Code (condition-code value)
`(setf (get ',condition-code 'condition-code) ,value))
;;; Storage Access Instructions.
(define-romp-instruction lcs ds #x4)
(define-romp-instruction lc d #xCE)
(define-romp-instruction lhas ds #x5)
(define-romp-instruction lha d #xCA)
(define-romp-instruction lhs r #xEB)
(define-romp-instruction lh d #xDA)
(define-romp-instruction ls ds #x7)
(define-romp-instruction l d #xCD)
(define-romp-instruction lm d #xC9)
(define-romp-instruction tsh d #xCF)
(define-romp-instruction stcs ds #x1)
(define-romp-instruction stc d #xDE)
(define-romp-instruction sths ds #x2)
(define-romp-instruction sth d #xDC)
(define-romp-instruction sts ds #x3)
(define-romp-instruction st d #xDD)
(define-romp-instruction stm d #xD9)
;;; Address Computation Instructions.
(define-romp-instruction cal d #xC8)
(define-romp-instruction cal16 d #xC2)
(define-romp-instruction cau d #xD8)
(define-romp-instruction cas x #x6)
(define-romp-instruction ca16 r #xF3)
(define-romp-instruction inc r #x91)
(define-romp-instruction dec r #x93)
(define-romp-instruction lis r #xA4)
;;; Basic Romp Branch Instructions.
(define-romp-instruction bala ba #x8A)
(define-romp-instruction balax ba #x8B)
(define-romp-instruction bali bi #x8C)
(define-romp-instruction balix bi #x8D)
(define-romp-instruction balr r #xEC)
(define-romp-instruction balrx r #xED)
(define-romp-instruction jb ji #x1)
(define-romp-instruction bb bi #x8E)
(define-romp-instruction bbx bi #x8F)
(define-romp-instruction bbr r #xEE)
(define-romp-instruction bbrx r #xEF)
(define-romp-instruction jnb ji #x0)
(define-romp-instruction bnb bi #x88)
(define-romp-instruction bnbx bi #x89)
(define-romp-instruction bnbr r #xE8)
(define-romp-instruction bnbrx r #xE9)
;;; Romp Trap Instrunctions.
(define-romp-instruction ti d #xCC)
(define-romp-instruction tgte r #xBD)
(define-romp-instruction tlt r #xBE)
;;; Romp Move and Insert Instructions.
(define-romp-instruction mc03 r #xF9)
(define-romp-instruction mc13 r #xFA)
(define-romp-instruction mc23 r #xFB)
(define-romp-instruction mc33 r #xFC)
(define-romp-instruction mc30 r #xFD)
(define-romp-instruction mc31 r #xFE)
(define-romp-instruction mc32 r #xFF)
(define-romp-instruction mftb r #xBC)
(define-romp-instruction mftbil r #x9D)
(define-romp-instruction mftbiu r #x9C)
(define-romp-instruction mttb r #xBF)
(define-romp-instruction mttbil r #x9F)
(define-romp-instruction mttbiu r #x9E)
;;; Romp Arithmetic Instructions.
(define-romp-instruction a r #xE1)
(define-romp-instruction ae r #xF1)
(define-romp-instruction aei d #xD1)
(define-romp-instruction ai d #xC1)
(define-romp-instruction ais r #x90)
(define-romp-instruction abs r #xE0)
(define-romp-instruction onec r #xF4)
(define-romp-instruction twoc r #xE4)
(define-romp-instruction c r #xB4)
(define-romp-instruction cis r #x94)
(define-romp-instruction ci d #xD4)
(define-romp-instruction cl r #xB3)
(define-romp-instruction cli d #xD3)
(define-romp-instruction exts r #xB1)
(define-romp-instruction s r #xE2)
(define-romp-instruction sf r #xB2)
(define-romp-instruction se r #xF2)
(define-romp-instruction sfi d #xD2)
(define-romp-instruction sis r #x92)
(define-romp-instruction d r #xB6)
(define-romp-instruction m r #xE6)
;;; Romp Logical Operations
(define-romp-instruction clrbl r #x99)
(define-romp-instruction clrbu r #x98)
(define-romp-instruction setbl r #x9B)
(define-romp-instruction setbu r #x9A)
(define-romp-instruction n r #xE5)
(define-romp-instruction nilz d #xC5)
(define-romp-instruction nilo d #xC6)
(define-romp-instruction niuz d #xD5)
(define-romp-instruction niuo d #xD6)
(define-romp-instruction o r #xE3)
(define-romp-instruction oil d #xC4)
(define-romp-instruction oiu d #xC3)
(define-romp-instruction x r #xE7)
(define-romp-instruction xil d #xC7)
(define-romp-instruction xiu d #xD7)
(define-romp-instruction clz r #xF5)
;;; Romp Shift Instructions
(define-romp-instruction sar r #xB0)
(define-romp-instruction sari r #xA0)
(define-romp-instruction sari16 r #xA1)
(define-romp-instruction sr r #xB8)
(define-romp-instruction sri r #xA8)
(define-romp-instruction sri16 r #xA9)
(define-romp-instruction srp r #xB9)
(define-romp-instruction srpi r #xAC)
(define-romp-instruction srpi16 r #xAD)
(define-romp-instruction sl r #xBA)
(define-romp-instruction sli r #xAA)
(define-romp-instruction sli16 r #xAB)
(define-romp-instruction slp r #xBB)
(define-romp-instruction slpi r #xAE)
(define-romp-instruction slpi16 r #xAF)
;;; Romp System Control Instructions.
(define-romp-instruction mts r #xB5)
(define-romp-instruction mfs r #x96)
(define-romp-instruction clrsb r #x95)
(define-romp-instruction setsb r #x97)
(define-romp-instruction lps d #xD0)
(define-romp-instruction wait r #xF0)
(define-romp-instruction svc d #xC0)
;;; Romp Input/Output Instructions.
(define-romp-instruction ior d #xCB)
(define-romp-instruction iow d #xDB)
;;; Define bit setting for examining condition codes.
(define-condition-code pz 8)
(define-condition-code lt 9)
(define-condition-code eq 10)
(define-condition-code gt 11)
(define-condition-code cz 12)
(define-condition-code ov 14)
(define-condition-code tb 15)
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.11 1990/05/24 13:24:06 wlott Exp $
;;;
;;; This file contains the extra code necessary to feed an entire file of
;;; assembly code to the assembler.
;;;
(in-package "C")
(defvar *do-assembly* nil
"If non-NIL, emit assembly code. If NIL, emit VOP templates.")
(defvar *lap-output-file* nil
"The FASL file currently being output to.")
(defvar *assembler-routines* nil
"A List of (name . label) for every entry point.")
(defun assemble-file (name &key
(output-file
(make-pathname :defaults name
:type "mips-fasl"))
trace-file)
(let* ((*do-assembly* t)
(name (pathname name))
(*lap-output-file* (open-fasl-file (pathname output-file) name))
(*assembler-routines* nil)
(won nil))
(unwind-protect
(let (*code-segment*
*elsewhere*
#-new-compiler (lisp::*in-compilation-unit* nil))
(init-assembler)
(load (merge-pathnames name (make-pathname :type "lisp")))
(fasl-dump-cold-load-form `(in-package ,(package-name *package*))
*lap-output-file*)
(assemble (*code-segment* nil)
(insert-segment *elsewhere*))
(let ((length (finalize-segment *code-segment*)))
(dump-assembler-routines *code-segment*
length
*assembler-routines*
*lap-output-file*))
(when trace-file
(with-open-file (file (if (eq trace-file t)
(make-pathname :defaults name
:type "trace")
trace-file)
:direction :output
:if-exists :supersede)
(format file "Assembly listing for ~A:~3%" (namestring name))
(dump-segment *code-segment* file)
(fresh-line file)))
(setq won t))
(close-fasl-file *lap-output-file* (not won)))
won))
(defstruct (reg-spec
(:print-function %print-reg-spec))
(kind :temp :type (member :arg :temp :result))
(name nil :type symbol)
(temp nil :type symbol)
(sc nil :type symbol)
(offset 0 :type fixnum))
(defun %print-reg-spec (spec stream depth)
(declare (ignore depth))
(format stream
"#<reg ~S ~S sc=~S offset=~S>"
(reg-spec-kind spec)
(reg-spec-name spec)
(reg-spec-sc spec)
(reg-spec-offset spec)))
(defun parse-reg-spec (kind name sc offset)
(let ((reg (make-reg-spec :kind kind :name name :sc sc :offset offset)))
(ecase kind
(:temp)
((:arg :res)
(setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
reg))
(defun emit-assemble (name regs code)
(let* ((labels nil)
(insts (mapcar #'(lambda (inst)
(cond ((symbolp inst)
(push inst labels)
`(emit-label ,inst))
(t
inst)))
code)))
`(let ((,name (gen-label))
,@(mapcar #'(lambda (label)
`(,label (gen-label)))
labels))
(push (cons ',name ,name) *assembler-routines*)
(assemble (*code-segment* ',name)
(emit-label ,name)
(let (,@(mapcar
#'(lambda (reg)
`(,(reg-spec-name reg)
(make-random-tn
:sc (sc-or-lose ',(reg-spec-sc reg))
:offset ,(reg-spec-offset reg))))
regs))
,@insts
(inst addu lip-tn lra-tn (- vm:word-bytes vm:other-pointer-type))
(inst j lip-tn)
(inst nop)))
(format t "~S assembled~%" ',name))))
(defun arg-or-res-spec (reg)
`(,(reg-spec-name reg)
:scs (,(reg-spec-sc reg))
,@(unless (eq (reg-spec-kind reg) :res)
`(:target ,(reg-spec-temp reg)))))
(defun emit-vop (name options vars)
(let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
(temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
(results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
(return-pc-label (make-symbol "RETURN-PC-LABEL"))
(return-pc (make-symbol "RETURN-PC"))
(lip (make-symbol "LIP"))
(ndescr (make-symbol "NDESCR")))
`(define-vop ,(if (atom name) (list name) name)
(:args ,@(mapcar #'arg-or-res-spec args))
,@(let ((index -1))
(mapcar #'(lambda (arg)
`(:temporary (:sc ,(reg-spec-sc arg)
:offset ,(reg-spec-offset arg)
:from (:argument ,(incf index))
:to (:eval 2))
,(reg-spec-temp arg)))
args))
,@(mapcar #'(lambda (temp)
`(:temporary (:sc ,(reg-spec-sc temp)
:offset ,(reg-spec-offset temp)
:from (:eval 1)
:to (:eval 3))
,(reg-spec-name temp)))
temps)
(:temporary (:scs (interior-reg) :type interior
:from (:eval 0) :to (:eval 1))
,lip)
(:temporary (:sc any-reg :offset lra-offset
:from (:eval 0) :to (:eval 1))
,return-pc)
(:temporary (:scs (non-descriptor-reg) :type random
:from (:eval 0) :to (:eval 1))
,ndescr)
,@(let ((index -1))
(mapcar #'(lambda (res)
`(:temporary (:sc ,(reg-spec-sc res)
:offset ,(reg-spec-offset res)
:from (:eval 2)
:to (:result ,(incf index))
:target ,(reg-spec-name res))
,(reg-spec-temp res)))
results))
(:results ,@(mapcar #'arg-or-res-spec results))
(:ignore ,lip ,@(mapcar #'reg-spec-name temps))
,@options
(:generator 247
(let ((,return-pc-label (gen-label)))
,@(mapcar #'(lambda (arg)
`(move ,(reg-spec-temp arg)
,(reg-spec-name arg)))
args)
(inst compute-lra-from-code ,return-pc code-tn ,return-pc-label)
(inst li ,ndescr (make-fixup ',name :assembly-routine))
(inst j ,ndescr)
(inst nop)
(emit-return-pc ,return-pc-label)
,@(mapcar #'(lambda (res)
`(move ,(reg-spec-name res)
,(reg-spec-temp res)))
results))))))
(defmacro define-assembly-routine ((name options &rest vars) &rest code)
(let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
(if *do-assembly*
(emit-assemble (if (atom name) name (car name)) regs code)
(emit-vop name options regs))))
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/array.lisp,v 1.8 1990/05/23 06:11:51 wlott Exp $
;;;
;;; This file contains the support routines for arrays and vectors.
;;;
;;; Written by William Lott.
;;;
(in-package "C")
(eval-when (eval)
(defmacro allocate-vector (type length words vector ndescr)
`(pseudo-atomic (,ndescr)
(inst or ,vector alloc-tn vm:other-pointer-type)
(inst addu alloc-tn alloc-tn (+ (1- (ash 1 vm:lowtag-bits))
(* vm:vector-data-offset vm:word-bytes)))
(inst addu alloc-tn alloc-tn ,words)
(inst li ,ndescr (lognot vm:lowtag-mask))
(inst and alloc-tn alloc-tn ,ndescr)
,(if (constantp type)
`(inst li ,ndescr ,type)
`(inst srl ,ndescr ,type vm:word-shift))
(storew ,ndescr ,vector 0 vm:other-pointer-type)
(storew ,length ,vector vm:vector-length-slot vm:other-pointer-type)))
(defmacro maybe-invoke-gc (vector words)
"Assure that VECTOR lies entirely before the guard page. WORDS is the
number of words of data in the vector."
(declare (ignore vector words))
nil)
); eval-when (eval)
(define-assembly-routine (allocate-vector
()
(:arg type any-reg a0-offset)
(:arg length any-reg a1-offset)
(:arg words any-reg a2-offset)
(:res result descriptor-reg a0-offset)
(:temp ndescr non-descriptor-reg nl0-offset)
(:temp vector descriptor-reg a3-offset))
(allocate-vector type length words vector ndescr)
(maybe-invoke-gc vector words)
(move result vector))
(define-assembly-routine (alloc-g-vector
()
(:arg length any-reg a0-offset)
(:arg fill any-reg a1-offset)
(:res result descriptor-reg a0-offset)
(:temp ndescr non-descriptor-reg nl0-offset)
(:temp lip interior-reg lip-offset)
(:temp vector descriptor-reg a3-offset))
(allocate-vector vm:simple-vector-type length length vector ndescr)
(inst beq length zero-tn done)
(inst addu lip vector (- (* vm:vector-data-offset vm:word-bytes)
vm:other-pointer-type))
loop
(storew fill lip)
(inst addu length length (fixnum -1))
(inst bne length zero-tn loop)
(inst addu lip lip vm:word-bytes)
done
(move result vector))
(define-assembly-routine (alloc-string
()
(:arg length any-reg a0-offset)
(:res result descriptor-reg a0-offset)
(:temp ndescr non-descriptor-reg nl0-offset)
(:temp words any-reg nl1-offset)
(:temp vector descriptor-reg a3-offset))
;; Note: When we calculate the number of words needed, we assure that there
;; will be at least one extra byte available. This allows us to pass strings
;; to C land without having to tack an extra null on the end ourselves.
;;
;; To do this quickly, we divide the length by the number of bytes and strip
;; off the two fixnum lowtag bits, add 1 (binary 1, not fixnum 1), and
;; shift back to a fixnum:
;;
;; length len>>4 1+ <<2
;; 0 0 1 4
;; 1 0 1 4
;; 3 0 1 4
;; 4 1 2 8
;; 7 1 2 8
;; 8 2 3 12
;;
(inst sra words length (+ vm:word-shift 2))
(inst addu words words 1)
(inst sll words words 2)
(allocate-vector vm:simple-string-type length words vector ndescr)
(maybe-invoke-gc vector words)
(move result vector))
;;;; Hash primitives
(define-assembly-routine (sxhash-simple-string
()
(:arg string descriptor-reg a0-offset)
(:res result any-reg a0-offset)
(:temp lip interior-reg lip-offset)
(:temp length any-reg a2-offset)
(:temp accum non-descriptor-reg nl0-offset)
(:temp data non-descriptor-reg nl1-offset)
(:temp byte non-descriptor-reg nl2-offset))
(loadw length string vm:vector-length-slot vm:other-pointer-type)
(inst addu lip string
(- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))
(inst b test)
(move accum zero-tn)
loop
(inst and byte data #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
(inst srl byte data 8)
(inst and byte byte #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
(inst srl byte data 16)
(inst and byte byte #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
(inst srl byte data 24)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
(inst addu lip lip 4)
test
(inst addu length length (fixnum -4))
(inst lw data lip 0)
(inst bgez length loop)
(inst nop)
(inst addu length length (fixnum 3))
(inst beq length zero-tn one-more)
(inst addu length length (fixnum -1))
(inst beq length zero-tn two-more)
(inst addu length length (fixnum -1))
(inst bne length zero-tn done)
(inst nop)
(inst srl byte data 16)
(inst and byte byte #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
two-more
(inst srl byte data 8)
(inst and byte byte #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
one-more
(inst and byte data #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
done
(inst sll result accum 5)
(inst srl result result 3))
(define-assembly-routine (sxhash-simple-substring
()
(:arg string descriptor-reg a0-offset)
(:arg length any-reg a1-offset)
(:res result any-reg a0-offset)
(:temp lip interior-reg lip-offset)
(:temp accum non-descriptor-reg nl0-offset)
(:temp data non-descriptor-reg nl1-offset)
(:temp byte non-descriptor-reg nl2-offset))
(inst addu lip string
(- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))
(inst b test)
(move accum zero-tn)
loop
(inst and byte data #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
(inst srl byte data 8)
(inst and byte byte #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
(inst srl byte data 16)
(inst and byte byte #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
(inst srl byte data 24)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
(inst addu lip lip 4)
test
(inst addu length length (fixnum -4))
(inst lw data lip 0)
(inst bgez length loop)
(inst nop)
(inst addu length length (fixnum 3))
(inst beq length zero-tn one-more)
(inst addu length length (fixnum -1))
(inst beq length zero-tn two-more)
(inst addu length length (fixnum -1))
(inst bne length zero-tn done)
(inst nop)
(inst srl byte data 16)
(inst and byte byte #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
two-more
(inst srl byte data 8)
(inst and byte byte #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
one-more
(inst and byte data #xff)
(inst xor accum accum byte)
(inst sll byte accum 5)
(inst srl accum accum 27)
(inst or accum accum byte)
done
(inst sll result accum 5)
(inst srl result result 3))
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/assem-rtns.lisp,v 1.11 1990/05/24 13:34:07 wlott Exp $
;;;
;;;
(in-package "C")
;;;; The undefined-function.
;;; Just signal an undefined-symbol error. Note: this must look like a
;;; function, because it magically gets called in place of a function when
;;; there is no real function to call.
(eval-when (eval)
(define-assembly-routine (undefined-function
()
(:temp cname any-reg cname-offset)
(:temp lexenv any-reg lexenv-offset)
(:temp function any-reg code-offset)
(:temp nargs any-reg nargs-offset)
(:temp lip interior-reg lip-offset)
(:temp temp non-descriptor-reg nl0-offset))
;; Allocate function header.
(align vm:lowtag-bits)
(inst word vm:function-header-type)
(dotimes (i (1- vm:function-header-code-offset))
(inst word 0))
;; Cause the error.
(cerror-call continue di:undefined-symbol-error cname)
continue
(let ((not-sym (generate-cerror-code di:object-not-symbol-error cname)))
(test-simple-type cname temp not-sym t vm:symbol-header-type))
(loadw lexenv cname vm:symbol-function-slot vm:other-pointer-type)
(loadw function lexenv vm:closure-function-slot vm:function-pointer-type)
(lisp-jump function lip))
); eval-when (eval)
;;;; Non-local exit noise.
(define-assembly-routine (unwind
()
(:arg block any-reg a0-offset)
(:arg start any-reg old-fp-offset)
(:arg count any-reg nargs-offset)
(:temp lip interior-reg lip-offset)
(:temp lra descriptor-reg lra-offset)
(:temp cur-uwp any-reg nl0-offset)
(:temp next-uwp any-reg nl1-offset)
(:temp target-uwp any-reg nl2-offset))
(declare (ignore start count))
(let ((error (generate-error-code di:invalid-unwind-error)))
(inst beq block zero-tn error))
(load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
(loadw target-uwp block vm:unwind-block-current-uwp-slot)
(inst bne cur-uwp target-uwp do-uwp)
(inst nop)
(move cur-uwp block)
do-exit
(loadw fp-tn cur-uwp vm:unwind-block-current-cont-slot)
(loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
(loadw lra cur-uwp vm:unwind-block-entry-pc-slot)
(lisp-return lra lip)
do-uwp
(loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
(inst b do-exit)
(store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
(define-assembly-routine (throw
()
(:arg target any-reg a0-offset)
(:arg start any-reg old-fp-offset)
(:arg count any-reg nargs-offset)
(:temp catch any-reg a1-offset)
(:temp tag descriptor-reg a2-offset)
(:temp ndescr non-descriptor-reg nl0-offset))
(load-symbol-value catch lisp::*current-catch-block*)
loop
(let ((error (generate-error-code di:unseen-throw-tag-error target)))
(inst beq catch zero-tn error)
(inst nop))
(loadw tag catch vm:catch-block-tag-slot)
(inst beq tag target exit)
(inst nop)
(inst b loop)
(loadw catch catch vm:catch-block-previous-catch-slot)
exit
(move target catch)
(inst li ndescr (make-fixup 'unwind :assembly-routine))
(inst j ndescr)
(inst nop))
This diff is collapsed.
R4 changes:
o Numerous bug fixes
o Multiprocess locking and error reporting made more robust
o Event queue consing reduced
o ICCCM support
R4.1 changes:
o Fix reported bugs and to include the vendor-specific
bug-fixing and performance-improving patches that I recently received.
o Code compiled with the R4 CLX will work with the R4.1X CLX, but code
compiled with the R4.1X CLX will NOT work with the R4 CLX. I made an effort
to ensure backward binary compatibility with R4 CLX so that old code doesn't
have to be recompiled to still work. It does have to be recompiled to fix
an event-queue bug, since the fix involved a change to the event-loop macro.
R4.2 changes:
o Atoms and visuals are now correctly maintained in a separate namespace from
windows, pixmaps, cursors, fonts, gcontexts, and colormaps.
o I have made an attempt to make socket code work for kcl and ibcl. I have
akcl here, but not kcl and ibcl, so it's only guesswork that kcl and ibcl
works.
o compile-clx and load-clx do more pathname merging to work around problems
in some lisp implementations. *default-pathname-defaults* is never bound
anymore.
o Some ansi common lisp stuff. If you have :ansi-common-lisp on *features*,
CLX will:
- Use the common-lisp package instead of the lisp package.
- Use the common lisp condition system, being careful not to stomp on
define-condition and type-error.
- Use declaim instead of proclaim.
- Use the dynamic-extent declaration for rest args and closures.
- Use print-unreadable-object.
o Code compiled with the R4 and R4.1 CLX will work with the R4.2 CLX, provided
you don't have :ansi-common-lisp on your features list. Code compiled with
the R4.2 CLX will NOT work with the R4 CLX.
These files contain beta code, but they have been tested to some extent under
Symbolics, TI, Lucid and Franz. The files have been given .l suffixes to keep
them within 12 characters, to keep SysV sites happy. Please rename them with
more appropriate suffixes for your system.
For Franz systems, see exclREADME.
For Symbolics systems, first rename all the .l files to .lisp. Then edit your
sys.translations file so that sys:x11;clx; points to this directory and put a
clx.system file in your sys:site;directory that has the form
(si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp")
in it. After that CLX can be compiled with the "Compile System CLX" command
and loaded with the "Load System CLX" command.
For TI systems, rename all the .l files to .lisp, and make a clx.translations
file in your sys:site; directory pointing to this directory and a
sys:site;clx.system file like the one described for symbolics systems above,
but with the defsystem file being in the clx:clx; directory. Then CLX can be
compiled with (make-system "CLX" :compile :noconfirm) and loaded with
(make-system "CLX" :noconfirm).
For Lucid systems, you should rename all the .l files to .lisp too (This might
not be possible on SysV systems). After loading the defsystem.l file, CLX can
be compiled with the (xlib:compile-clx) function and loaded with the
(xlib:load-clx) form.
The ms-patch.uu file is a patch to Lucid version 2 systems. You probably
don't need it, as you are probably running Lucid version 3 or later, but if
you are still using Lucid version 2, you need this patch. You'll need to
uudecode it to produce the binary.
For kcl systems, after loading the defsystem.l file, CLX can be compiled with
the (xlib:compile-clx) function and loaded with the (xlib:load-clx) form.
For more information, see defsystem.l and provide.l.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
;;; Load this file if you want to compile CLX in its entirety.
(proclaim '(optimize (speed 3) (safety 0) (space 1)
(compilation-speed 0)))
;;; Hide CLOS from CLX, so objects stay implemented as structures.
;;;
(when (find-package "CLOS")
(rename-package (find-package "CLOS") "NO-CLOS-HERE"))
(when (find-package "PCL")
(rename-package (find-package "PCL") "NO-PCL-HERE"))
(when (find-package "XLIB")
(rename-package (find-package "XLIB") "OLD-XLIB"))
;(make-package "XLIB" :use '("LISP"))
(compile-file "clx:defsystem.lisp" :error-file nil)
(load "clx:defsystem.fasl")
(xlib:compile-clx (pathname "clx:"))
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment