Skip to content
Snippets Groups Projects
Commit e4b609ed authored by gerd's avatar gerd
Browse files

* src/ldb/, src/assembler/: Removed; dead code.

parent 1e896049
No related branches found
No related tags found
No related merge requests found
;;; -*- 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)
# Makefile for generating the real Makefile.
# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/Makefile.boot,v 1.3 1991/11/08 00:22:04 wlott Exp $
#
Makefile: Makefile.orig
/usr/cs/lib/cpp < Makefile.orig > Makefile.NEW
mv Makefile.NEW Makefile
make depend
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/Makefile.orig,v 1.29 1992/03/06 12:39:06 wlott Exp $ */
INCLS = -I. -I/usr/misc/.X11/include
SRCS = ldb.c egets.c coreparse.c alloc.c monitor.c print.c \
os.c os-common.c arch.c vars.c assem.s parse.c interrupt.c test.c \
search.c validate.c gc.c globals.c dynbind.c breakpoint.c \
regnames.c backtrace.c bitbash.c save.c purify.c socket.c
OBJS = ldb.o egets.o coreparse.o alloc.o monitor.o print.o \
os.o os-common.o arch.o vars.o assem.o parse.o interrupt.o test.o \
search.o validate.o gc.o globals.o dynbind.o breakpoint.o \
regnames.o backtrace.o bitbash.o save.o purify.o socket.o
#ifdef mips
CFLAGS = -O ${INCLS}
UNDEFSYMPATTERN=&
ASSEMFILE='mips-assem.s'
ARCH_SRC="mips-arch.c"
#endif
#ifdef ibmrt
CFLAGS = -g ${INCLS}
UNDEFSYMPATTERN=_&
ASSEMFILE='rt-assem.s'
ARCH_SRC="rt-arch.c"
#endif
#ifdef sparc
CFLAGS = -O ${INCLS}
UNDEFSYMPATTERN=_&
ASSEMFILE='sparc-assem.s'
ARCH_SRC="sparc-arch.c"
#endif
#ifdef MACH
OS_SRC=mach-os.c
OS_LINK_FLAGS=
OS_SRCS=
OS_OBJS=
OS_LIBS=-lmach
CPP=/usr/cs/lib/cpp
#else
#ifdef sun
OS_SRC=sunos-os.c
OS_LINK_FLAGS=-Bstatic
OS_SRCS=fake-mach.c
OS_OBJS=fake-mach.o
OS_LIBS=
#endif
CPP=/lib/cpp
#endif
all: ldb.map
ldb.map: ldb
echo -n 'Map file for ldb version ' > ldb.map
cat version >> ldb.map
nm -gp ldb >> ldb.map
ldb: ${OBJS} ${OS_OBJS} version undefineds
echo -n '1 + ' | cat - version | bc > ,version
mv ,version version
cc ${CFLAGS} -DVERSION=`cat version` -c version.c
cc ${OS_LINK_FLAGS} `cat undefineds` -o ,ldb \
${OBJS} ${OS_OBJS} version.o \
${OS_LIBS} -lm -lc
mv -f ,ldb ldb
version:
echo 0 > version
undefineds: undefineds.src
${CPP} undefineds.src | \
sed -e '/^#/d' -e '/^[ ]*$$/d' -e 's/.*/-u ${UNDEFSYMPATTERN}/' | \
sort -u > ,undefineds
mv ,undefineds undefineds
assem.s:
rm -f assem.s
ln -s ${ASSEMFILE} assem.s
os.c:
rm -f os.c
ln -s ${OS_SRC} os.c
arch.c:
rm -f arch.c
ln -s ${ARCH_SRC} arch.c
#ifdef mips
/* MIPS specific stuff. */
/* If we get an interrupt while in lisp code, the global pointer */
/* is trash. Therefore, we can't use the GP relative addressing */
/* mode in the interrupt handlers. */
arch.o: arch.c
cc ${CFLAGS} -G 0 -c arch.c
interrupt.o: interrupt.c
cc ${CFLAGS} -G 0 -c interrupt.c
assem.o: assem.s lisp.h lispregs.h globals.h
as -G 0 -o $@ assem.s
#endif
#ifdef ibmrt
assem.o: assem.s
${CPP} assem.s | as -o assem.o
#endif
#ifdef sparc
/* We need this shit because as runs the wrong preprocessor. */
#ifdef MACH
ASSEMDEFS=-DMACH
#else
ASSEMDEFS=-UMACH
#endif
assem.o: assem.s lisp.h lispregs.h globals.h
as -P ${ASSEMDEFS} -o $@ assem.s
#endif
socket.o: socket.c
cc ${CFLAGS} -DUNIXCONN -c socket.c
lisp.h:
@echo "You must run genesis to create lisp.h!"
@false
clean:
rm -f lisp.h os.c arch.c assem.s undefineds *.o ldb ldb.map
depend: depends
depends: os.c arch.c assem.s
rm -f Makefile.BAK
ln Makefile Makefile.BAK
sed -n '1,/^\/\*@/p' Makefile > Makefile.NEW
cc -M ${INCLS} ${SRCS} ${OS_SRCS} | egrep -v ' /usr/' >> Makefile.NEW
mv Makefile.NEW Makefile
rm Makefile.BAK
/*@ Do not edit anything after this line. */
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/alloc.c,v 1.7 1991/10/22 18:36:50 wlott Exp $ */
#include "lisp.h"
#include "ldb.h"
#include "alloc.h"
#include "globals.h"
#ifdef ibmrt
#define GET_FREE_POINTER() ((lispobj *)SymbolValue(ALLOCATION_POINTER))
#define SET_FREE_POINTER(new_value) \
(SetSymbolValue(ALLOCATION_POINTER,(lispobj)(new_value)))
#define GET_GC_TRIGGER() ((lispobj *)SymbolValue(INTERNAL_GC_TRIGGER))
#define SET_GC_TRIGGER(new_value) \
(SetSymbolValue(INTERNAL_GC_TRIGGER,(lispobj)(new_value)))
#else
#define GET_FREE_POINTER() current_dynamic_space_free_pointer
#define SET_FREE_POINTER(new_value) \
(current_dynamic_space_free_pointer = (new_value))
#define GET_GC_TRIGGER() current_auto_gc_trigger
#define SET_GC_TRIGGER(new_value) \
clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
#endif
/****************************************************************
Allocation Routines.
****************************************************************/
static lispobj *alloc(bytes)
int bytes;
{
lispobj *result;
/* Round to dual word boundry. */
bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
result = GET_FREE_POINTER();
SET_FREE_POINTER(result + (bytes / sizeof(lispobj)));
if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) {
SET_GC_TRIGGER((char *)GET_FREE_POINTER()
- (char *)current_dynamic_space);
}
return result;
}
lispobj *alloc_unboxed(type, words)
int type, words;
{
lispobj *result;
result = alloc((1 + words) * sizeof(lispobj));
*result = (lispobj) (words << type_Bits) | type;
return result;
}
lispobj alloc_vector(type, length, size)
int type, length, size;
{
struct vector *result;
result = (struct vector *)alloc((2 + (length*size + 31) / 32) * sizeof(lispobj));
result->header = type;
result->length = fixnum(length);
return ((lispobj)result)|type_OtherPointer;
}
lispobj alloc_cons(car, cdr)
lispobj car, cdr;
{
struct cons *ptr = (struct cons *)alloc(sizeof(struct cons));
ptr->car = car;
ptr->cdr = cdr;
return (lispobj)ptr | type_ListPointer;
}
lispobj alloc_number(n)
long n;
{
struct bignum *ptr;
if (-0x20000000 < n && n < 0x20000000)
return fixnum(n);
else {
ptr = (struct bignum *)alloc_unboxed(type_Bignum, 1);
ptr->digits[0] = n;
return (lispobj) ptr | type_OtherPointer;
}
}
lispobj alloc_string(str)
char *str;
{
int len = strlen(str);
lispobj result = alloc_vector(type_SimpleString, len+1, 8);
struct vector *vec = (struct vector *)PTR(result);
vec->length = fixnum(len);
strcpy(vec->data, str);
return result;
}
lispobj alloc_sap(ptr)
char *ptr;
{
struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 1);
sap->pointer = ptr;
return (lispobj) sap | type_OtherPointer;
}
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/alloc.h,v 1.1 1990/02/24 19:37:11 wlott Exp $ */
lispobj alloc_cons(), alloc_string(), alloc_number();
#ifndef __ARCH_H__
#define __ARCH_H__
extern char *arch_init();
extern void arch_skip_instruction();
extern os_vm_address_t arch_get_bad_addr();
#endif /* __ARCH_H__ */
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/backtrace.c,v 1.7 1990/10/22 12:38:28 wlott Exp $
*
* Simple backtrace facility. More or less from Rob's lisp version.
*/
#include <stdio.h>
#include <signal.h>
#include "ldb.h"
#include "lisp.h"
#include "globals.h"
#include "interrupt.h"
#include "lispregs.h"
/* Sigh ... I know what the call frame looks like and it had
better not change. */
struct call_frame {
struct call_frame *old_cont;
lispobj saved_lra;
lispobj code;
lispobj other_state[5];
};
struct call_info {
struct call_frame *frame;
int interrupted;
struct code *code;
lispobj lra;
int pc; /* Note: this is the trace file offset, not the actual pc. */
};
#define HEADER_LENGTH(header) ((header)>>8)
static struct code *
code_pointer(object)
lispobj object;
{
lispobj *headerp, header;
int type, len;
headerp = (lispobj *) PTR(object);
header = *headerp;
type = TypeOf(header);
switch (type) {
case type_CodeHeader:
break;
case type_ReturnPcHeader:
case type_FunctionHeader:
case type_ClosureFunctionHeader:
len = HEADER_LENGTH(header);
if (len == 0)
headerp = NULL;
else
headerp -= len;
break;
default:
headerp = NULL;
}
return (struct code *) headerp;
}
static
cs_valid_pointer_p(pointer)
struct call_frame *pointer;
{
return (((char *) control_stack <= (char *) pointer) &&
((char *) pointer < (char *) current_control_stack_pointer));
}
static void
info_from_lisp_state(info)
struct call_info *info;
{
info->frame = (struct call_frame *)current_control_frame_pointer;
info->interrupted = 0;
info->code = NULL;
info->lra = 0;
info->pc = 0;
previous_info(info);
}
static void
info_from_sigcontext(info, csp)
struct call_info *info;
struct sigcontext *csp;
{
unsigned long pc;
info->interrupted = 1;
if (LowtagOf(csp->sc_regs[CODE]) == type_FunctionPointer) {
/* We tried to call a function, but crapped out before $CODE could be fixed up. Probably an undefined function. */
info->frame = (struct call_frame *)csp->sc_regs[OCFP];
info->lra = (lispobj)csp->sc_regs[LRA];
info->code = code_pointer(info->lra);
pc = (unsigned long)PTR(info->lra);
}
else {
info->frame = (struct call_frame *)csp->sc_regs[CFP];
info->code = code_pointer(csp->sc_regs[CODE]);
info->lra = NIL;
pc = csp->sc_pc;
}
if (info->code != NULL)
info->pc = pc - (unsigned long) info->code -
(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
else
info->pc = 0;
}
static int
previous_info(info)
struct call_info *info;
{
struct call_frame *this_frame;
int free;
struct sigcontext *csp;
if (!cs_valid_pointer_p(info->frame)) {
printf("Bogus callee value (0x%08x).\n", (unsigned long)info->frame);
return 0;
}
this_frame = info->frame;
info->lra = this_frame->saved_lra;
info->frame = this_frame->old_cont;
info->interrupted = 0;
if (info->frame == NULL || info->frame == this_frame)
return 0;
if (info->lra == NIL) {
/* We were interrupted. Find the correct sigcontext. */
free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
while (free-- > 0) {
csp = lisp_interrupt_contexts[free];
if ((struct call_frame *)(csp->sc_regs[CFP]) == info->frame) {
info_from_sigcontext(info, csp);
break;
}
}
}
else {
info->code = code_pointer(info->lra);
if (info->code != NULL)
info->pc = (unsigned long)PTR(info->lra) -
(unsigned long)info->code -
(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
else
info->pc = 0;
}
return 1;
}
void
backtrace(nframes)
int nframes;
{
struct call_info info;
info_from_lisp_state(&info);
do {
printf("<Frame 0x%08x%s, ", (unsigned long) info.frame,
info.interrupted ? " [interrupted]" : "");
if (info.code != (struct code *) 0) {
lispobj function;
printf("CODE: 0x%08x, ", (unsigned long) info.code | type_OtherPointer);
function = info.code->entry_points;
while (function != NIL) {
struct function_header *header;
lispobj name;
header = (struct function_header *) PTR(function);
name = header->name;
if (LowtagOf(name) == type_OtherPointer) {
lispobj *object;
object = (lispobj *) PTR(name);
if (TypeOf(*object) == type_SymbolHeader) {
struct symbol *symbol;
symbol = (struct symbol *) object;
object = (lispobj *) PTR(symbol->name);
}
if (TypeOf(*object) == type_SimpleString) {
struct vector *string;
string = (struct vector *) object;
printf("%s, ", (char *) string->data);
} else
printf("(Not simple string???), ");
} else
printf("(Not other pointer???), ");
function = header->next;
}
}
else
printf("CODE: ???, ");
if (info.lra != NIL)
printf("LRA: 0x%08x, ", (unsigned long)info.lra);
else
printf("<no LRA>, ");
if (info.pc)
printf("PC: 0x%x>\n", info.pc);
else
printf("PC: ???>\n");
} while (--nframes > 0 && previous_info(&info));
}
unsigned long bit_bash_low_masks[] = {
0x00000000,
0x00000001,
0x00000003,
0x00000007,
0x0000000f,
0x0000001f,
0x0000003f,
0x0000007f,
0x000000ff,
0x000001ff,
0x000003ff,
0x000007ff,
0x00000fff,
0x00001fff,
0x00003fff,
0x00007fff,
0x0000ffff,
0x0001ffff,
0x0003ffff,
0x0007ffff,
0x000fffff,
0x001fffff,
0x003fffff,
0x007fffff,
0x00ffffff,
0x01ffffff,
0x03ffffff,
0x07ffffff,
0x0fffffff,
0x1fffffff,
0x3fffffff,
0x7fffffff,
0xffffffff
};
unsigned long bit_bash_high_masks[] = {
0x00000000,
0x80000000,
0xc0000000,
0xe0000000,
0xf0000000,
0xf8000000,
0xfc000000,
0xfe000000,
0xff000000,
0xff800000,
0xffc00000,
0xffe00000,
0xfff00000,
0xfff80000,
0xfffc0000,
0xfffe0000,
0xffff0000,
0xffff8000,
0xffffc000,
0xffffe000,
0xfffff000,
0xfffff800,
0xfffffc00,
0xfffffe00,
0xffffff00,
0xffffff80,
0xffffffc0,
0xffffffe0,
0xfffffff0,
0xfffffff8,
0xfffffffc,
0xfffffffe,
0xffffffff,
};
#include <stdio.h>
#include <signal.h>
#include "ldb.h"
#include "lisp.h"
#include "os.h"
#include "lispregs.h"
#include "globals.h"
#ifdef ibmrt
typedef unsigned short inst;
#else
typedef unsigned long inst;
#endif
#define REAL_LRA_SLOT 0
#define KNOWN_RETURN_P_SLOT 1
#define BOGUS_LRA_CONSTANTS 2
static inst swap_insts(code_obj, pc_offset, new_inst)
lispobj code_obj;
int pc_offset;
inst new_inst;
{
struct code *code;
inst *addr, old_inst;
code = (struct code *)PTR(code_obj);
addr = (inst *)((char *)code + HeaderValue(code->header)*sizeof(lispobj)
+ pc_offset);
old_inst = *addr;
*addr = new_inst;
os_flush_icache((os_vm_address_t)addr, sizeof(inst));
return old_inst;
}
inst breakpoint_install(code_obj, pc_offset)
lispobj code_obj;
int pc_offset;
{
return swap_insts(code_obj, pc_offset,
#ifdef mips
(trap_Breakpoint << 16) | 0xd
#endif
#ifdef sparc
trap_Breakpoint
#endif
#ifdef ibmrt
0 /* hack */
#endif
);
}
void breakpoint_remove(code_obj, pc_offset, orig_inst)
lispobj code_obj;
int pc_offset;
inst orig_inst;
{
swap_insts(code_obj, pc_offset, orig_inst);
}
static lispobj find_code(scp)
struct sigcontext *scp;
{
lispobj code = scp->sc_regs[CODE];
lispobj header = *(lispobj *)PTR(code);
switch (TypeOf(header)) {
case type_CodeHeader:
return code;
case type_ReturnPcHeader:
return code - HeaderValue(header)*4;
case type_FunctionHeader:
case type_ClosureFunctionHeader:
return code - type_FunctionPointer - HeaderValue(header)*4
+ type_OtherPointer;
default:
crap_out("Strange thing in $CODE at breakpoint.");
}
}
static int calc_offset(code, pc)
struct code *code;
unsigned long pc;
{
unsigned long code_start;
int offset;
code_start = (unsigned long)code
+ HeaderValue(code->header)*sizeof(lispobj);
if (pc < code_start)
return 0;
offset = pc - code_start;
if (offset >= code->code_size)
return 0;
return offset;
}
int breakpoint_after_offset(scp)
struct sigcontext *scp;
{
struct code *code = (struct code *)PTR(find_code(scp));
#ifdef sparc
return calc_offset(code, scp->sc_npc);
#endif
#ifdef mips
inst cur_inst = *(inst *)scp->sc_pc;
int opcode = cur_inst >> 26;
struct sigcontext tmp;
if (opcode == 1 || ((opcode & 0x3c) == 0x4) || ((cur_inst & 0xf00e0000) == 0x80000000)) {
tmp = *scp;
emulate_branch(&tmp, cur_inst);
return calc_offset(code, tmp.sc_pc);
}
else
return calc_offset(code, scp->sc_pc + 4);
#endif
}
static void internal_handle_breakpoint(scp, code)
struct sigcontext *scp;
lispobj code;
{
struct code *codeptr = (struct code *)PTR(code);
lispobj *args;
args = current_control_stack_pointer;
current_control_stack_pointer += 3;
args[0] = fixnum(calc_offset(codeptr, scp->sc_pc));
args[1] = code;
args[2] = alloc_sap(scp);
funcall_sym(HANDLE_BREAKPOINT, args, 3);
scp->sc_mask = sigblock(0);
}
handle_breakpoint(signal, subcode, scp)
int signal, subcode;
struct sigcontext *scp;
{
internal_handle_breakpoint(scp, find_code(scp));
}
handle_function_end_breakpoint(signal, subcode, scp)
int signal, subcode;
struct sigcontext *scp;
{
extern char function_end_breakpoint_guts[], function_end_breakpoint_trap[];
lispobj code = scp->sc_pc - (unsigned long)function_end_breakpoint_trap
+ (unsigned long)function_end_breakpoint_guts -
((sizeof(struct code)+((BOGUS_LRA_CONSTANTS-1)*sizeof(lispobj))+7)&~7)
+ type_OtherPointer;
struct code *codeptr = (struct code *)PTR(code);
lispobj lra;
internal_handle_breakpoint(scp, code);
lra = codeptr->constants[REAL_LRA_SLOT];
if (codeptr->constants[KNOWN_RETURN_P_SLOT] == NIL)
scp->sc_regs[CODE] = lra;
scp->sc_pc = lra - type_OtherPointer+sizeof(lispobj);
}
#define CORE_PAGESIZE OS_VM_DEFAULT_PAGESIZE
#define CORE_MAGIC (('C' << 24) | ('O' << 16) | ('R' << 8) | 'E')
#define CORE_END 3840
#define CORE_NDIRECTORY 3861
#define CORE_VALIDATE 3845
#define CORE_VERSION 3860
#define CORE_MACHINE_STATE 3862
#define DYNAMIC_SPACE_ID (1)
#define STATIC_SPACE_ID (2)
#define READ_ONLY_SPACE_ID (3)
struct ndir_entry {
long identifier;
long nwords;
long data_page;
long address;
long page_count;
};
struct machine_state {
lispobj *csp;
lispobj *fp;
#ifndef ibmrt
lispobj *bsp;
#endif
char *number_stack_start;
long sigcontext_page;
long control_stack_page;
long binding_stack_page;
long number_stack_page;
};
This diff is collapsed.
/*
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/dynbind.c,v 1.3 1991/02/16 00:59:56 wlott Exp $
*
* Support for dynamic binding from C.
*/
#include "ldb.h"
#include "lisp.h"
#include "globals.h"
#ifdef ibmrt
#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value))
#else
#define GetBSP() ((struct binding *)current_binding_stack_pointer)
#define SetBSP(value) (current_binding_stack_pointer=(lispobj *)(value))
#endif
bind_variable(symbol, value)
lispobj symbol, value;
{
lispobj old_value;
struct binding *binding;
old_value = SymbolValue(symbol);
binding = GetBSP();
SetBSP(binding+1);
binding->value = old_value;
binding->symbol = symbol;
SetSymbolValue(symbol, value);
}
unbind()
{
struct binding *binding;
lispobj symbol;
binding = GetBSP() - 1;
symbol = binding->symbol;
SetSymbolValue(symbol, binding->value);
binding->symbol = 0;
SetBSP(binding);
}
unbind_to_here(bsp)
lispobj *bsp;
{
struct binding *target = (struct binding *)bsp;
struct binding *binding = GetBSP();
lispobj symbol;
while (target < binding) {
binding--;
symbol = binding->symbol;
if (symbol) {
SetSymbolValue(symbol, binding->value);
binding->symbol = 0;
}
}
SetBSP(binding);
}
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