From: William Harold Newman Date: Sat, 6 Oct 2001 17:18:30 +0000 (+0000) Subject: 0.pre7.49: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=dec94b039e8ec90baf21463df839a6181de606f6;p=sbcl.git 0.pre7.49: deleting old byte-compiler/byte-interpreter stuff.. ..find . -name *byte*lisp | xargs rm ..find . -name *.lisp | xargs egrep -i 'byte.*comp' --- diff --git a/BUGS b/BUGS index 00127a1..5df3d1b 100644 --- a/BUGS +++ b/BUGS @@ -88,9 +88,9 @@ WORKAROUND: to really grok function declarations. 7: - The "byte compiling top-level form:" output ought to be condensed. + The "compiling top-level form:" output ought to be condensed. Perhaps any number of such consecutive lines ought to turn into a - single "byte compiling top-level forms:" line. + single "compiling top-level forms:" line. 10: The way that the compiler munges types with arguments together @@ -1017,21 +1017,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: ; (while making load form for #) ; A logical host can't be dumped as a constant: # -114: - reported by Martin Atzmueller 2001-06-25; originally from CMU CL bugs - collection: - (in-package :cl-user) - ;;; This file causes the byte compiler to fail. - (declaim (optimize (speed 0) (safety 1))) - (defun tst1 () - (values - (multiple-value-list - (catch 'a - (return-from tst1))))) - The error message in sbcl-0.6.12.42 is - internal error, failed AVER: - "(COMMON-LISP:EQUAL (SB!C::BYTE-BLOCK-INFO-START-STACK SB!INT:INFO) SB!C::STACK)" - 115: reported by Martin Atzmueller 2001-06-25; originally from CMU CL bugs collection: @@ -1090,42 +1075,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: Raymond Toy comments that this is tricky on the X86 since its FPU uses 80-bit precision internally. -119: - a bug in the byte compiler and/or interpreter: Compile - (IN-PACKAGE :CL-USER) - (DECLAIM (OPTIMIZE (SPEED 0) (SAFETY 1) (DEBUG 1))) - (DEFUN BAR (&REST DIMS) - (IF (EVERY #'INTEGERP DIMS) - 1 - 2)) - then execute (BAR '(1 2 3 4)). In sbcl-0.pre7.14.flaky4.8 - this gives a TYPE-ERROR, - The value #:UNINITIALIZED-EVAL-STACK-ELEMENT is not - of type (MOD 536870911). - The same error will probably occur in earlier versions as well, - although the name of the uninitialized-element placeholder will - be shorter. - - The same thing happens if the compiler macro expansion of - EVERY into MAP is hand-expanded: - (defun bar2 (dims) - (if (block blockname - (map nil - (lambda (dim) - (let ((pred-value (funcall #'integerp dim))) - (unless pred-value - (return-from blockname - nil)))) - dims) - t) - 1 - 2)) - CMU CL doesn't have this compiler macro expansion, so it was - immune to the original bug in BAR, but once we hand-expand it - into BAR2, CMU CL 18c has the same bug. (Run (BAR '(NIL NIL)).) - - The native compiler handles it fine, both in SBCL and in CMU CL. - 120a: The compiler incorrectly figures the return type of (DEFUN FOO (FRAME UP-FRAME) diff --git a/doc/sbcl.1 b/doc/sbcl.1 index 9161690..15b88f9 100644 --- a/doc/sbcl.1 +++ b/doc/sbcl.1 @@ -257,12 +257,8 @@ Unlike its distinguished ancestor CMU CL, SBCL is currently on X86 straightforward to port the CMU CL support for SPARC, or to port to NetBSD. -As of version 0.6.11, SBCL requires on the order of 16Mb to run. In -some future version, this number could shrink significantly, since -large parts of the system are far from execution bottlenecks and could -reasonably be stored in compact byte compiled form. (CMU CL does this -routinely; the only reason SBCL doesn't currently do this is a -combination of bootstrapping technicalities and inertia.) +As of version 0.6.13, SBCL requires on the order of 16Mb RAM to run +on X86 systems. .SH ENVIRONMENT diff --git a/make-host-2.sh b/make-host-2.sh index 303ec01..1f1a1b9 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -61,10 +61,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (defun in-target-cross-compilation-mode (fn) "Call FN with everything set up appropriately for cross-compiling a target file." - (let (;; Life is simpler at genesis/cold-load time if we - ;; needn't worry about byte-compiled code. - (sb!ext:*byte-compile-top-level* nil) - ;; In order to increase microefficiency of the target Lisp, + (let (;; In order to increase microefficiency of the target Lisp, ;; enable old CMU CL defined-function-types-never-change ;; optimizations. (ANSI says users aren't supposed to ;; redefine our functions anyway; and developers can diff --git a/make-target-2.sh b/make-target-2.sh index 9464a48..a617288 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -29,8 +29,8 @@ echo //doing warm init --core output/cold-sbcl.core \ --sysinit /dev/null --userinit /dev/null <<-'EOF' || exit 1 - ;; Now that we use the byte compiler for macros, - ;; interpreted /SHOW doesn't work until later in init. + ;; Now that we use the compiler for macros, interpreted + ;; /SHOW doesn't work until later in init. #+sb-show (print "/hello, world!") ;; Until PRINT-OBJECT and other machinery is set up, diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3186dbe..20d6752 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -144,15 +144,6 @@ "MULTIPLY-FIXNUMS" "NEGATE-BIGNUM" "SUBTRACT-BIGNUM" "SXHASH-BIGNUM")) - ;; FIXME: byte compiler/interpreter to go away completely - #| - #s(sb-cold:package-data - :name "SB!BYTECODE" - :doc "private: stuff related to the bytecode interpreter" - :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL") - :export ()) - |# - #s(sb-cold:package-data :name "SB!C" :doc "private: implementation of the compiler" diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp deleted file mode 100644 index 563b66c..0000000 --- a/src/code/byte-interp.lisp +++ /dev/null @@ -1,1311 +0,0 @@ -;;;; the byte code interpreter - -;;; FIXME: should really be in SB!BYTECODE -(in-package "SB!C") - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -;;; We need at least this level of DEBUGness in order for the local -;;; declaration in WITH-DEBUGGER-INFO to take effect. -;;; -;;; FIXME: This will cause source code location information to be -;;; compiled into the executable, which will probably cause problems -;;; for users running without the sources and/or without the -;;; build-the-system readtable. -(declaim (optimize (debug 2))) - -;;; Return a function type approximating the type of a byte-compiled -;;; function. We really only capture the arg signature. -(defun byte-function-type (x) - (specifier-type - (etypecase x - (simple-byte-function - `(function ,(make-list (simple-byte-function-num-args x) - :initial-element t) - *)) - (hairy-byte-function - (collect ((res)) - (let ((min (hairy-byte-function-min-args x)) - (max (hairy-byte-function-max-args x))) - (dotimes (i min) (res t)) - (when (> max min) - (res '&optional) - (dotimes (i (- max min)) - (res t)))) - (when (hairy-byte-function-rest-arg-p x) - (res '&rest t)) - (ecase (hairy-byte-function-keywords-p x) - ((t :allow-others) - (res '&key) - (dolist (key (hairy-byte-function-keywords x)) - (res `(,(car key) t))) - (when (eql (hairy-byte-function-keywords-p x) :allow-others) - (res '&allow-other-keys))) - ((nil))) - `(function ,(res) *)))))) - -;;;; the 'evaluation stack' -;;;; -;;;; (The name dates back to CMU CL, when it was used for the IR1 -;;;; interpreted implementation of EVAL. In SBCL >=0.7.0, it's just -;;;; the byte interpreter stack.) - -(defvar *eval-stack* (make-array 100)) ; will grow as needed - -;;; the index of the next free element of the interpreter's evaluation stack -(defvar *eval-stack-top* 0) - -#!-sb-fluid (declaim (inline eval-stack-ref)) -(defun eval-stack-ref (offset) - (declare (type stack-pointer offset)) - (svref sb!bytecode::*eval-stack* offset)) - -#!-sb-fluid (declaim (inline (setf eval-stack-ref))) -(defun (setf eval-stack-ref) (new-value offset) - (declare (type stack-pointer offset)) - (setf (svref sb!bytecode::*eval-stack* offset) new-value)) - -(defun push-eval-stack (value) - (let ((len (length (the simple-vector sb!bytecode::*eval-stack*))) - (sp *eval-stack-top*)) - (when (= len sp) - (let ((new-stack (make-array (ash len 1)))) - (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len) - (setf sb!bytecode::*eval-stack* new-stack))) - (setf *eval-stack-top* (1+ sp)) - (setf (eval-stack-ref sp) value))) - -(defun allocate-eval-stack (amount) - (let* ((len (length (the simple-vector sb!bytecode::*eval-stack*))) - (sp *eval-stack-top*) - (new-sp (+ sp amount))) - (declare (type index sp new-sp)) - (when (>= new-sp len) - (let ((new-stack (make-array (ash new-sp 1)))) - (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len) - (setf sb!bytecode::*eval-stack* new-stack))) - (setf *eval-stack-top* new-sp) - (let ((stack sb!bytecode::*eval-stack*)) - (do ((i sp (1+ i))) ; FIXME: Use CL:FILL. - ((= i new-sp)) - (setf (svref stack i) '#:uninitialized-eval-stack-element)))) - (values)) - -(defun pop-eval-stack () - (let* ((new-sp (1- *eval-stack-top*)) - (value (eval-stack-ref new-sp))) - (setf *eval-stack-top* new-sp) - value)) - -(defmacro multiple-value-pop-eval-stack ((&rest vars) &body body) - #+nil (declare (optimize (inhibit-warnings 3))) - (let ((num-vars (length vars)) - (index -1) - (new-sp-var (gensym "NEW-SP-")) - (decls nil)) - (loop - (unless (and (consp body) - (consp (car body)) - (eq (caar body) 'declare)) - (return)) - (push (pop body) decls)) - `(let ((,new-sp-var (- *eval-stack-top* ,num-vars))) - (declare (type stack-pointer ,new-sp-var)) - (let ,(mapcar #'(lambda (var) - `(,var (eval-stack-ref - (+ ,new-sp-var ,(incf index))))) - vars) - ,@(nreverse decls) - (setf *eval-stack-top* ,new-sp-var) - ,@body)))) - -(defun eval-stack-copy (dest src count) - (declare (type stack-pointer dest src count)) - (let ((stack *eval-stack*)) - (if (< dest src) - (dotimes (i count) - (setf (svref stack dest) (svref stack src)) - (incf dest) - (incf src)) - (do ((si (1- (+ src count)) - (1- si)) - (di (1- (+ dest count)) - (1- di))) - ((< si src)) - (declare (fixnum si di)) - (setf (svref stack di) (svref stack si))))) - (values)) - -;;;; component access magic - -#!-sb-fluid (declaim (inline component-ref)) -(defun component-ref (component pc) - (declare (type code-component component) - (type pc pc)) - (sap-ref-8 (code-instructions component) pc)) - -#!-sb-fluid (declaim (inline (setf component-ref))) -(defun (setf component-ref) (value component pc) - (declare (type (unsigned-byte 8) value) - (type code-component component) - (type pc pc)) - (setf (sap-ref-8 (code-instructions component) pc) value)) - -#!-sb-fluid (declaim (inline component-ref-signed)) -(defun component-ref-signed (component pc) - (let ((byte (component-ref component pc))) - (if (logbitp 7 byte) - (logior (ash -1 8) byte) - byte))) - -#!-sb-fluid (declaim (inline component-ref-24)) -(defun component-ref-24 (component pc) - (logior (ash (component-ref component pc) 16) - (ash (component-ref component (1+ pc)) 8) - (component-ref component (+ pc 2)))) - -;;;; debugging support - -;;; This macro binds three magic variables. When the debugger notices that -;;; these three variables are bound, it makes a byte-code frame out of the -;;; supplied information instead of a compiled frame. We set each var in -;;; addition to binding it so the compiler doens't optimize away the binding. -(defmacro with-debugger-info ((component pc fp) &body body) - `(let ((%byte-interp-component ,component) - (%byte-interp-pc ,pc) - (%byte-interp-fp ,fp)) - ;; FIXME: This will cause source code location information to be compiled - ;; into the executable, which will probably cause problems for users - ;; running without the sources and/or without the build-the-system - ;; readtable. - (declare (optimize (debug 3))) - (setf %byte-interp-component %byte-interp-component) - (setf %byte-interp-pc %byte-interp-pc) - (setf %byte-interp-fp %byte-interp-fp) - ,@body)) - -(defun byte-install-breakpoint (component pc) - (declare (type code-component component) - (type pc pc) - (values (unsigned-byte 8))) - (let ((orig (component-ref component pc))) - (setf (component-ref component pc) - #.(logior byte-xop - (xop-index-or-lose 'breakpoint))) - orig)) - -(defun byte-remove-breakpoint (component pc orig) - (declare (type code-component component) - (type pc pc) - (type (unsigned-byte 8) orig) - (values (unsigned-byte 8))) - (setf (component-ref component pc) orig)) - -(defun byte-skip-breakpoint (component pc fp orig) - (declare (type code-component component) - (type pc pc) - (type stack-pointer fp) - (type (unsigned-byte 8) orig)) - (byte-interpret-byte component fp pc orig)) - -;;;; system constants - -;;; a table mapping system constant indices to run-time values. We don't -;;; reference the compiler variable at load time, since the interpreter is -;;; loaded first. -(defparameter *system-constants* - (let ((res (make-array 256))) - (dolist (x '#.(collect ((res)) - (dohash (key value *system-constant-codes*) - (res (cons key value))) - (res))) - (let ((key (car x)) - (value (cdr x))) - (setf (svref res value) - (if (and (consp key) (eq (car key) '%fdefinition-marker%)) - (fdefinition-object (cdr key) t) - key)))) - res)) - -;;;; byte compiled function constructors/extractors - -(defun initialize-byte-compiled-function (xep) - (declare (type byte-function xep)) - (push xep (code-header-ref (byte-function-component xep) - sb!vm:code-trace-table-offset-slot)) - (setf (funcallable-instance-function xep) - #'(instance-lambda (&more context count) - (let ((old-sp *eval-stack-top*)) - (declare (type stack-pointer old-sp)) - (dotimes (i count) - (push-eval-stack (%more-arg context i))) - (invoke-xep nil 0 old-sp 0 count xep)))) - xep) - -(defun make-byte-compiled-closure (xep closure-vars) - (declare (type byte-function xep) - (type simple-vector closure-vars)) - (let ((res (make-byte-closure xep closure-vars))) - (setf (funcallable-instance-function res) - #'(instance-lambda (&more context count) - (let ((old-sp *eval-stack-top*)) - (declare (type stack-pointer old-sp)) - (dotimes (i count) - (push-eval-stack (%more-arg context i))) - (invoke-xep nil 0 old-sp 0 count - (byte-closure-function res) - (byte-closure-data res))))) - res)) - -;;;; INLINEs - -;;; (The idea here seems to be to make sure it's at least 100, -;;; in order to be able to compile the 32+ inline functions -;;; in EXPAND-INTO-INLINES as intended. -- WHN 19991206) -(eval-when (:compile-toplevel :execute) - (setq sb!ext:*inline-expansion-limit* 100)) - -;;; FIXME: This doesn't seem to be needed in the target Lisp, only -;;; at build-the-system time. -;;; -;;; KLUDGE: This expands into code like -;;; (IF (ZEROP (LOGAND BYTE 16)) -;;; (IF (ZEROP (LOGAND BYTE 8)) -;;; (IF (ZEROP (LOGAND BYTE 4)) -;;; (IF (ZEROP (LOGAND BYTE 2)) -;;; (IF (ZEROP (LOGAND BYTE 1)) -;;; (ERROR "Unknown inline function, id=~D" 0) -;;; (ERROR "Unknown inline function, id=~D" 1)) -;;; (IF (ZEROP (LOGAND BYTE 1)) -;;; (ERROR "Unknown inline function, id=~D" 2) -;;; (ERROR "Unknown inline function, id=~D" 3))) -;;; (IF (ZEROP (LOGAND BYTE 2)) -;;; ..) ..) ..) -;;; That's probably more efficient than doing a function call (even a -;;; local function call) for every byte interpreted, but I doubt it's -;;; as fast as doing a jump through a table of sixteen addresses. -;;; Perhaps it would be good to recode this as a straightforward -;;; CASE statement and redirect the cleverness previously devoted to -;;; this code to an optimizer for CASE which is smart enough to -;;; implement suitable code as jump tables. -(defmacro expand-into-inlines () - #+nil (declare (optimize (inhibit-warnings 3))) - (named-let build-dispatch ((bit 4) - (base 0)) - (if (minusp bit) - (let ((info (svref *inline-functions* base))) - (if info - (let* ((spec (type-specifier - (inline-function-info-type info))) - (arg-types (second spec)) - (result-type (third spec)) - (args (make-gensym-list (length arg-types))) - (func - `(the ,result-type - (,(inline-function-info-interpreter-function info) - ,@args)))) - `(multiple-value-pop-eval-stack ,args - (declare ,@(mapcar #'(lambda (type var) - `(type ,type ,var)) - arg-types args)) - ,(if (and (consp result-type) - (eq (car result-type) 'values)) - (let ((results (make-gensym-list - (length (cdr result-type))))) - `(multiple-value-bind ,results ,func - ,@(mapcar #'(lambda (res) - `(push-eval-stack ,res)) - results))) - `(push-eval-stack ,func)))) - `(error "unknown inline function, id=~D" ,base))) - `(if (zerop (logand byte ,(ash 1 bit))) - ,(build-dispatch (1- bit) base) - ,(build-dispatch (1- bit) (+ base (ash 1 bit))))))) - -#!-sb-fluid (declaim (inline value-cell-setf)) -(defun value-cell-setf (value cell) - (value-cell-set cell value) - value) - -#!-sb-fluid (declaim (inline setf-symbol-value)) -(defun setf-symbol-value (value symbol) - (setf (symbol-value symbol) value)) - -#!-sb-fluid (declaim (inline %setf-instance-ref)) -(defun %setf-instance-ref (new-value instance index) - (setf (%instance-ref instance index) new-value)) - -(eval-when (:compile-toplevel) - -(sb!xc:defmacro %byte-symbol-value (x) - `(let ((x ,x)) - (unless (boundp x) - (with-debugger-info (component pc fp) - (error "unbound variable: ~S" x))) - (symbol-value x))) - -(sb!xc:defmacro %byte-car (x) - `(let ((x ,x)) - (unless (listp x) - (with-debugger-info (component pc fp) - (error 'simple-type-error :item x :expected-type 'list - :format-control "non-list argument to CAR: ~S" - :format-arguments (list x)))) - (car x))) - -(sb!xc:defmacro %byte-cdr (x) - `(let ((x ,x)) - (unless (listp x) - (with-debugger-info (component pc fp) - (error 'simple-type-error :item x :expected-type 'list - :format-control "non-list argument to CDR: ~S" - :format-arguments (list x)))) - (cdr x))) - -) ; EVAL-WHEN - -#!-sb-fluid (declaim (inline %byte-special-bind)) -(defun %byte-special-bind (value symbol) - (sb!sys:%primitive bind value symbol) - (values)) - -#!-sb-fluid (declaim (inline %byte-special-unbind)) -(defun %byte-special-unbind () - (sb!sys:%primitive unbind) - (values)) - -;;;; two-arg function stubs -;;;; -;;;; We have two-arg versions of some n-ary functions that are normally -;;;; open-coded. - -(defun two-arg-char= (x y) (char= x y)) -(defun two-arg-char< (x y) (char< x y)) -(defun two-arg-char> (x y) (char> x y)) -(defun two-arg-char-equal (x y) (char-equal x y)) -(defun two-arg-char-lessp (x y) (char-lessp x y)) -(defun two-arg-char-greaterp (x y) (char-greaterp x y)) -(defun two-arg-string= (x y) (string= x y)) -(defun two-arg-string< (x y) (string= x y)) -(defun two-arg-string> (x y) (string= x y)) - -;;;; funny functions - -;;; (used both by the byte interpreter and by the IR1 interpreter) -(defun %progv (vars vals fun) - (progv vars vals - (funcall fun))) - -;;;; XOPs - -;;; Extension operations (XOPs) are various magic things that the byte -;;; interpreter needs to do, but can't be represented as a function call. -;;; When the byte interpreter encounters an XOP in the byte stream, it -;;; tail-calls the corresponding XOP routine extracted from *byte-xops*. -;;; The XOP routine can do whatever it wants, probably re-invoking the -;;; byte interpreter. - -;;; Fetch an 8/24 bit operand out of the code stream. -(eval-when (:compile-toplevel :execute) - (sb!xc:defmacro with-extended-operand ((component pc operand new-pc) - &body body) - (once-only ((n-component component) - (n-pc pc)) - `(multiple-value-bind (,operand ,new-pc) - (let ((,operand (component-ref ,n-component ,n-pc))) - (if (= ,operand #xff) - (values (component-ref-24 ,n-component (1+ ,n-pc)) - (+ ,n-pc 4)) - (values ,operand (1+ ,n-pc)))) - (declare (type index ,operand ,new-pc)) - ,@body)))) - -;;; If a real XOP hasn't been defined, this gets invoked and signals an -;;; error. This shouldn't happen in normal operation. -(defun undefined-xop (component old-pc pc fp) - (declare (ignore component old-pc pc fp)) - (error "undefined XOP")) - -;;; a simple vector of the XOP functions -(declaim (type (simple-vector 256) *byte-xops*)) -(defvar *byte-xops* - (make-array 256 :initial-element #'undefined-xop)) - -;;; Define a XOP function and install it in *BYTE-XOPS*. -(eval-when (:compile-toplevel :execute) - (sb!xc:defmacro define-xop (name lambda-list &body body) - (let ((defun-name (symbolicate "BYTE-" name "-XOP"))) - `(progn - (defun ,defun-name ,lambda-list - ,@body) - (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name) - ',defun-name)))) - -;;; This is spliced in by the debugger in order to implement breakpoints. -(define-xop breakpoint (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc) - (ignore pc) - (type stack-pointer fp)) - ;; Invoke the debugger. - (with-debugger-info (component old-pc fp) - (sb!di::handle-breakpoint component old-pc fp)) - ;; Retry the breakpoint XOP in case it was replaced with the original - ;; displaced byte-code. - (byte-interpret component old-pc fp)) - -;;; This just duplicates whatever is on the top of the stack. -(define-xop dup (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let ((value (eval-stack-ref (1- *eval-stack-top*)))) - (push-eval-stack value)) - (byte-interpret component pc fp)) - -(define-xop make-closure (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let* ((num-closure-vars (pop-eval-stack)) - (closure-vars (make-array num-closure-vars))) - (declare (type index num-closure-vars) - (type simple-vector closure-vars)) - (named-let frob ((index (1- num-closure-vars))) - (unless (minusp index) - (setf (svref closure-vars index) (pop-eval-stack)) - (frob (1- index)))) - (push-eval-stack (make-byte-compiled-closure (pop-eval-stack) - closure-vars))) - (byte-interpret component pc fp)) - -(define-xop merge-unknown-values (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (labels ((grovel (remaining-blocks block-count-ptr) - (declare (type index remaining-blocks) - (type stack-pointer block-count-ptr)) - (declare (values index stack-pointer)) - (let ((block-count (eval-stack-ref block-count-ptr))) - (declare (type index block-count)) - (if (= remaining-blocks 1) - (values block-count block-count-ptr) - (let ((src (- block-count-ptr block-count))) - (declare (type index src)) - (multiple-value-bind (values-above dst) - (grovel (1- remaining-blocks) (1- src)) - (eval-stack-copy dst src block-count) - (values (+ values-above block-count) - (+ dst block-count)))))))) - (multiple-value-bind (total-count end-ptr) - (grovel (pop-eval-stack) (1- *eval-stack-top*)) - (setf (eval-stack-ref end-ptr) total-count) - (setf *eval-stack-top* (1+ end-ptr)))) - (byte-interpret component pc fp)) - -(define-xop default-unknown-values (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let* ((desired (pop-eval-stack)) - (supplied (pop-eval-stack)) - (delta (- desired supplied))) - (declare (type index desired supplied) - (type fixnum delta)) - (cond ((minusp delta) - (incf *eval-stack-top* delta)) - ((plusp delta) - (dotimes (i delta) - (push-eval-stack nil))))) - (byte-interpret component pc fp)) - -;;; %THROW is compiled down into this xop. The stack contains the tag, the -;;; values, and then a count of the values. We special case various small -;;; numbers of values to keep from consing if we can help it. -;;; -;;; Basically, we just extract the values and the tag and then do a throw. -;;; The native compiler will convert this throw into whatever is necessary -;;; to throw, so we don't have to duplicate all that cruft. -(define-xop throw (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc) - (ignore pc) - (type stack-pointer fp)) - (let ((num-results (pop-eval-stack))) - (declare (type index num-results)) - (case num-results - (0 - (let ((tag (pop-eval-stack))) - (with-debugger-info (component old-pc fp) - (throw tag (values))))) - (1 - (multiple-value-pop-eval-stack - (tag result) - (with-debugger-info (component old-pc fp) - (throw tag result)))) - (2 - (multiple-value-pop-eval-stack - (tag result0 result1) - (with-debugger-info (component old-pc fp) - (throw tag (values result0 result1))))) - (t - (let ((results nil)) - (dotimes (i num-results) - (push (pop-eval-stack) results)) - (let ((tag (pop-eval-stack))) - (with-debugger-info (component old-pc fp) - (throw tag (values-list results))))))))) - -;;; This is used for both CATCHes and BLOCKs that are closed over. We -;;; establish a catcher for the supplied tag (from the stack top), and -;;; recursivly enter the byte interpreter. If the byte interpreter exits, -;;; it must have been because of a BREAKUP (see below), so we branch (by -;;; tail-calling the byte interpreter) to the pc returned by BREAKUP. -;;; If we are thrown to, then we branch to the address encoded in the 3 bytes -;;; following the catch XOP. -(define-xop catch (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let ((new-pc (block nil - (let ((results - (multiple-value-list - (catch (pop-eval-stack) - (return (byte-interpret component (+ pc 3) fp)))))) - (let ((num-results 0)) - (declare (type index num-results)) - (dolist (result results) - (push-eval-stack result) - (incf num-results)) - (push-eval-stack num-results)) - (component-ref-24 component pc))))) - (byte-interpret component new-pc fp))) - -;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the -;;; pc following the BREAKUP XOP and the drop-through code in CATCH or -;;; TAGBODY will do the correct thing. -(define-xop breakup (component old-pc pc fp) - (declare (ignore component old-pc fp) - (type pc pc)) - pc) - -;;; This is exactly like THROW, except that the tag is the last thing -;;; on the stack instead of the first. This is used for RETURN-FROM -;;; (hence the name). -(define-xop return-from (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc) - (ignore pc) - (type stack-pointer fp)) - (let ((tag (pop-eval-stack)) - (num-results (pop-eval-stack))) - (declare (type index num-results)) - (case num-results - (0 - (with-debugger-info (component old-pc fp) - (throw tag (values)))) - (1 - (let ((value (pop-eval-stack))) - (with-debugger-info (component old-pc fp) - (throw tag value)))) - (2 - (multiple-value-pop-eval-stack - (result0 result1) - (with-debugger-info (component old-pc fp) - (throw tag (values result0 result1))))) - (t - (let ((results nil)) - (dotimes (i num-results) - (push (pop-eval-stack) results)) - (with-debugger-info (component old-pc fp) - (throw tag (values-list results)))))))) - -;;; Similar to CATCH, except for TAGBODY. One significant difference is that -;;; when thrown to, we don't want to leave the dynamic extent of the tagbody -;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP -;;; is used to blow out. When that happens, we just branch to the pc supplied -;;; by BREAKUP. -(define-xop tagbody (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let* ((tag (pop-eval-stack)) - (new-pc (block nil - (loop - (setf pc - (catch tag - (return (byte-interpret component pc fp)))))))) - (byte-interpret component new-pc fp))) - -;;; Yup, you guessed it. This XOP implements GO. There are no values to -;;; pass, so we don't have to mess with them, and multiple exits can all be -;;; using the same tag so we have to pass the pc we want to go to. -(define-xop go (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc pc) - (type stack-pointer fp)) - (let ((tag (pop-eval-stack)) - (new-pc (component-ref-24 component pc))) - (with-debugger-info (component old-pc fp) - (throw tag new-pc)))) - -;;; UNWIND-PROTECTs are handled significantly different in the byte -;;; compiler and the native compiler. Basically, we just use the -;;; native compiler's UNWIND-PROTECT, and let it worry about -;;; continuing the unwind. -(define-xop unwind-protect (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let ((new-pc nil)) - (unwind-protect - (setf new-pc (byte-interpret component (+ pc 3) fp)) - (unless new-pc - ;; The cleanup function expects 3 values to be one the stack, so - ;; we have to put something there. - (push-eval-stack nil) - (push-eval-stack nil) - (push-eval-stack nil) - ;; Now run the cleanup code. - (byte-interpret component (component-ref-24 component pc) fp))) - (byte-interpret component new-pc fp))) - -(define-xop fdefn-function-or-lose (component old-pc pc fp) - (let* ((fdefn (pop-eval-stack)) - (fun (fdefn-function fdefn))) - (declare (type fdefn fdefn)) - (cond (fun - (push-eval-stack fun) - (byte-interpret component pc fp)) - (t - (with-debugger-info (component old-pc fp) - (error 'undefined-function :name (fdefn-name fdefn))))))) - -;;; This is used to insert placeholder arguments for unused arguments -;;; to local calls. -(define-xop push-n-under (component old-pc pc fp) - (declare (ignore old-pc)) - (with-extended-operand (component pc howmany new-pc) - (let ((val (pop-eval-stack))) - (allocate-eval-stack howmany) - (push-eval-stack val)) - (byte-interpret component new-pc fp))) - -;;;; type checking - -;;; These two hashtables map between type specifiers and type -;;; predicate functions that test those types. They are initialized -;;; according to the standard type predicates of the target system. -(defvar *byte-type-predicates* (make-hash-table :test 'equal)) -(defvar *byte-predicate-types* (make-hash-table :test 'eq)) - -(loop for (type predicate) in - '#.(loop for (type . predicate) in - *backend-type-predicates* - collect `(,(type-specifier type) ,predicate)) - do - (let ((fun (fdefinition predicate))) - (setf (gethash type *byte-type-predicates*) fun) - (setf (gethash fun *byte-predicate-types*) type))) - -;;; This is called by the loader to convert a type specifier into a -;;; type predicate (as used by the TYPE-CHECK XOP.) If it is a -;;; structure type with a predicate or has a predefined predicate, -;;; then return the predicate function, otherwise return the CTYPE -;;; structure for the type. -(defun load-type-predicate (desc) - (or (gethash desc *byte-type-predicates*) - (let ((type (specifier-type desc))) - (if (typep type 'structure-class) - (let ((info (layout-info (class-layout type)))) - (if (and info (eq (dd-type info) 'structure)) - (let ((predicate-name (dd-predicate-name info))) - (if (and predicate-name (fboundp predicate-name)) - (fdefinition predicate-name) - type)) - type)) - type)))) - -;;; Check the type of the value on the top of the stack. The type is -;;; designated by an entry in the constants. If the value is a -;;; function, then it is called as a type predicate. Otherwise, the -;;; value is a CTYPE object, and we call %TYPEP on it. -(define-xop type-check (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc pc) - (type stack-pointer fp)) - (with-extended-operand (component pc operand new-pc) - (let ((value (eval-stack-ref (1- *eval-stack-top*))) - (type (code-header-ref component - (+ operand sb!vm:code-constants-offset)))) - (unless (if (functionp type) - (funcall type value) - (%typep value type)) - (with-debugger-info (component old-pc fp) - (error 'type-error - :datum value - :expected-type (if (functionp type) - (gethash type *byte-predicate-types*) - (type-specifier type)))))) - - (byte-interpret component new-pc fp))) - -;;;; the actual byte-interpreter - -;;; The various operations are encoded as follows. -;;; -;;; 0000xxxx push-local op -;;; 0001xxxx push-arg op [push-local, but negative] -;;; 0010xxxx push-constant op -;;; 0011xxxx push-system-constant op -;;; 0100xxxx push-int op -;;; 0101xxxx push-neg-int op -;;; 0110xxxx pop-local op -;;; 0111xxxx pop-n op -;;; 1000nxxx call op -;;; 1001nxxx tail-call op -;;; 1010nxxx multiple-call op -;;; 10110xxx local-call -;;; 10111xxx local-tail-call -;;; 11000xxx local-multiple-call -;;; 11001xxx return -;;; 1101000r branch -;;; 1101001r if-true -;;; 1101010r if-false -;;; 1101011r if-eq -;;; 11011xxx Xop -;;; 11100000 -;;; to various inline functions. -;;; 11111111 -;;; -;;; This encoding is rather hard wired into BYTE-INTERPRET due to the -;;; binary dispatch tree. - -(defvar *byte-trace* nil) - -;;; the main entry point to the byte interpreter -(defun byte-interpret (component pc fp) - (declare (type code-component component) - (type pc pc) - (type stack-pointer fp)) - (byte-interpret-byte component pc fp (component-ref component pc))) - -;;; This is separated from BYTE-INTERPRET in order to let us continue -;;; from a breakpoint without having to replace the breakpoint with -;;; the original instruction and arrange to somehow put the breakpoint -;;; back after executing the instruction. We just leave the breakpoint -;;; there, and call this function with the byte that the breakpoint -;;; displaced. -(defun byte-interpret-byte (component pc fp byte) - (declare (type code-component component) - (type pc pc) - (type stack-pointer fp) - (type (unsigned-byte 8) byte)) - (locally - #+nil (declare (optimize (inhibit-warnings 3))) - (when *byte-trace* - (let ((*byte-trace* nil)) - (format *trace-output* - "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%" - pc fp *eval-stack-top* byte - (subseq sb!bytecode::*eval-stack* fp *eval-stack-top*))))) - (if (zerop (logand byte #x80)) - ;; Some stack operation. No matter what, we need the operand, - ;; so compute it. - (multiple-value-bind (operand new-pc) - (let ((operand (logand byte #xf))) - (if (= operand #xf) - (let ((operand (component-ref component (1+ pc)))) - (if (= operand #xff) - (values (component-ref-24 component (+ pc 2)) - (+ pc 5)) - (values operand (+ pc 2)))) - (values operand (1+ pc)))) - (if (zerop (logand byte #x40)) - (push-eval-stack (if (zerop (logand byte #x20)) - (if (zerop (logand byte #x10)) - (eval-stack-ref (+ fp operand)) - (eval-stack-ref (- fp operand 5))) - (if (zerop (logand byte #x10)) - (code-header-ref - component - (+ operand sb!vm:code-constants-offset)) - (svref *system-constants* operand)))) - (if (zerop (logand byte #x20)) - (push-eval-stack (if (zerop (logand byte #x10)) - operand - (- (1+ operand)))) - (if (zerop (logand byte #x10)) - (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack)) - (if (zerop operand) - (let ((operand (pop-eval-stack))) - (declare (type index operand)) - (decf *eval-stack-top* operand)) - (decf *eval-stack-top* operand))))) - (byte-interpret component new-pc fp)) - (if (zerop (logand byte #x40)) - ;; Some kind of call. - (let ((args (let ((args (logand byte #x07))) - (if (= args #x07) - (pop-eval-stack) - args)))) - (if (zerop (logand byte #x20)) - (let ((named (not (zerop (logand byte #x08))))) - (if (zerop (logand byte #x10)) - ;; Call for single value. - (do-call component pc (1+ pc) fp args named) - ;; Tail call. - (do-tail-call component pc fp args named))) - (if (zerop (logand byte #x10)) - ;; Call for multiple-values. - (do-call component pc (- (1+ pc)) fp args - (not (zerop (logand byte #x08)))) - (if (zerop (logand byte #x08)) - ;; Local call - (do-local-call component pc (+ pc 4) fp args) - ;; Local tail-call - (do-tail-local-call component pc fp args))))) - (if (zerop (logand byte #x20)) - ;; local-multiple-call, Return, branch, or Xop. - (if (zerop (logand byte #x10)) - ;; local-multiple-call or return. - (if (zerop (logand byte #x08)) - ;; Local-multiple-call. - (do-local-call component pc (- (+ pc 4)) fp - (let ((args (logand byte #x07))) - (if (= args #x07) - (pop-eval-stack) - args))) - ;; Return. - (let ((num-results - (let ((num-results (logand byte #x7))) - (if (= num-results 7) - (pop-eval-stack) - num-results)))) - (do-return fp num-results))) - ;; Branch or Xop. - (if (zerop (logand byte #x08)) - ;; Branch. - (if (if (zerop (logand byte #x04)) - (if (zerop (logand byte #x02)) - t - (pop-eval-stack)) - (if (zerop (logand byte #x02)) - (not (pop-eval-stack)) - (multiple-value-pop-eval-stack - (val1 val2) - (eq val1 val2)))) - ;; Branch taken. - (byte-interpret - component - (if (zerop (logand byte #x01)) - (component-ref-24 component (1+ pc)) - (+ pc 2 - (component-ref-signed component (1+ pc)))) - fp) - ;; Branch not taken. - (byte-interpret component - (if (zerop (logand byte #x01)) - (+ pc 4) - (+ pc 2)) - fp)) - ;; Xop. - (multiple-value-bind (sub-code new-pc) - (let ((operand (logand byte #x7))) - (if (= operand #x7) - (values (component-ref component (+ pc 1)) - (+ pc 2)) - (values operand (1+ pc)))) - (funcall (the function (svref *byte-xops* sub-code)) - component pc new-pc fp)))) - ;; some miscellaneous inline function - (progn - (expand-into-inlines) - (byte-interpret component (1+ pc) fp)))))) - -(defun do-local-call (component pc old-pc old-fp num-args) - (declare (type pc pc) - (type return-pc old-pc) - (type stack-pointer old-fp) - (type (integer 0 #.call-arguments-limit) num-args)) - (invoke-local-entry-point component (component-ref-24 component (1+ pc)) - component old-pc - (- *eval-stack-top* num-args) - old-fp)) - -(defun do-tail-local-call (component pc fp num-args) - (declare (type code-component component) (type pc pc) - (type stack-pointer fp) - (type index num-args)) - (let ((old-fp (eval-stack-ref (- fp 1))) - (old-sp (eval-stack-ref (- fp 2))) - (old-pc (eval-stack-ref (- fp 3))) - (old-component (eval-stack-ref (- fp 4))) - (start-of-args (- *eval-stack-top* num-args))) - (eval-stack-copy old-sp start-of-args num-args) - (setf *eval-stack-top* (+ old-sp num-args)) - (invoke-local-entry-point component (component-ref-24 component (1+ pc)) - old-component old-pc old-sp old-fp))) - -(defun invoke-local-entry-point (component target old-component old-pc old-sp - old-fp &optional closure-vars) - (declare (type pc target) - (type return-pc old-pc) - (type stack-pointer old-sp old-fp) - (type (or null simple-vector) closure-vars)) - (when closure-vars - (named-let more ((index (1- (length closure-vars)))) - (unless (minusp index) - (push-eval-stack (svref closure-vars index)) - (more (1- index))))) - (push-eval-stack old-component) - (push-eval-stack old-pc) - (push-eval-stack old-sp) - (push-eval-stack old-fp) - (multiple-value-bind (stack-frame-size entry-pc) - (let ((byte (component-ref component target))) - (if (= byte 255) - (values (component-ref-24 component (1+ target)) (+ target 4)) - (values (* byte 2) (1+ target)))) - (declare (type pc entry-pc)) - (let ((fp *eval-stack-top*)) - (allocate-eval-stack stack-frame-size) - (byte-interpret component entry-pc fp)))) - -;;; Call a function with some arguments popped off of the interpreter -;;; stack, and restore the SP to the specified value. -(defun byte-apply (function num-args restore-sp) - (declare (type function function) (type index num-args)) - (let ((start (- *eval-stack-top* num-args))) - (declare (type stack-pointer start)) - (macrolet ((frob () - `(case num-args - ,@(loop for n below 8 - collect `(,n (call-1 ,n))) - (t - (let ((args ()) - (end (+ start num-args))) - (declare (type stack-pointer end)) - (do ((i (1- end) (1- i))) - ((< i start)) - (declare (fixnum i)) - (push (eval-stack-ref i) args)) - (setf *eval-stack-top* restore-sp) - (apply function args))))) - (call-1 (n) - (collect ((binds) - (args)) - (dotimes (i n) - (let ((dum (gensym))) - (binds `(,dum (eval-stack-ref (+ start ,i)))) - (args dum))) - `(let ,(binds) - (setf *eval-stack-top* restore-sp) - (funcall function ,@(args)))))) - (frob)))) - -;;; Note: negative RET-PC is a convention for "we need multiple return -;;; values". -(defun do-call (old-component call-pc ret-pc old-fp num-args named) - (declare (type code-component old-component) - (type pc call-pc) - (type return-pc ret-pc) - (type stack-pointer old-fp) - (type (integer 0 #.call-arguments-limit) num-args) - (type (member t nil) named)) - (let* ((old-sp (- *eval-stack-top* num-args 1)) - (fun-or-fdefn (eval-stack-ref old-sp)) - (function (if named - (or (fdefn-function fun-or-fdefn) - (with-debugger-info (old-component call-pc old-fp) - (error 'undefined-function - :name (fdefn-name fun-or-fdefn)))) - fun-or-fdefn))) - (declare (type stack-pointer old-sp) - (type (or function fdefn) fun-or-fdefn) - (type function function)) - (typecase function - (byte-function - (invoke-xep old-component ret-pc old-sp old-fp num-args function)) - (byte-closure - (invoke-xep old-component ret-pc old-sp old-fp num-args - (byte-closure-function function) - (byte-closure-data function))) - (t - (cond ((minusp ret-pc) - (let* ((ret-pc (- ret-pc)) - (results - (multiple-value-list - (with-debugger-info - (old-component ret-pc old-fp) - (byte-apply function num-args old-sp))))) - (dolist (result results) - (push-eval-stack result)) - (push-eval-stack (length results)) - (byte-interpret old-component ret-pc old-fp))) - (t - (push-eval-stack - (with-debugger-info - (old-component ret-pc old-fp) - (byte-apply function num-args old-sp))) - (byte-interpret old-component ret-pc old-fp))))))) - -(defun do-tail-call (component pc fp num-args named) - (declare (type code-component component) - (type pc pc) - (type stack-pointer fp) - (type (integer 0 #.call-arguments-limit) num-args) - (type (member t nil) named)) - (let* ((start-of-args (- *eval-stack-top* num-args)) - (fun-or-fdefn (eval-stack-ref (1- start-of-args))) - (function (if named - (or (fdefn-function fun-or-fdefn) - (with-debugger-info (component pc fp) - (error 'undefined-function - :name (fdefn-name fun-or-fdefn)))) - fun-or-fdefn)) - (old-fp (eval-stack-ref (- fp 1))) - (old-sp (eval-stack-ref (- fp 2))) - (old-pc (eval-stack-ref (- fp 3))) - (old-component (eval-stack-ref (- fp 4)))) - (declare (type stack-pointer old-fp old-sp start-of-args) - (type return-pc old-pc) - (type (or fdefn function) fun-or-fdefn) - (type function function)) - (typecase function - (byte-function - (eval-stack-copy old-sp start-of-args num-args) - (setf *eval-stack-top* (+ old-sp num-args)) - (invoke-xep old-component old-pc old-sp old-fp num-args function)) - (byte-closure - (eval-stack-copy old-sp start-of-args num-args) - (setf *eval-stack-top* (+ old-sp num-args)) - (invoke-xep old-component old-pc old-sp old-fp num-args - (byte-closure-function function) - (byte-closure-data function))) - (t - ;; We are tail-calling native code. - (cond ((null old-component) - ;; We were called by native code. - (byte-apply function num-args old-sp)) - ((minusp old-pc) - ;; We were called for multiple values. So return multiple - ;; values. - (let* ((old-pc (- old-pc)) - (results - (multiple-value-list - (with-debugger-info - (old-component old-pc old-fp) - (byte-apply function num-args old-sp))))) - (dolist (result results) - (push-eval-stack result)) - (push-eval-stack (length results)) - (byte-interpret old-component old-pc old-fp))) - (t - ;; We were called for one value. So return one value. - (push-eval-stack - (with-debugger-info - (old-component old-pc old-fp) - (byte-apply function num-args old-sp))) - (byte-interpret old-component old-pc old-fp))))))) - -(defvar *byte-trace-calls* nil) - -(defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep - &optional closure-vars) - (declare (type (or null code-component) old-component) - (type index num-args) - (type return-pc ret-pc) - (type stack-pointer old-sp old-fp) - (type byte-function xep) - (type (or null simple-vector) closure-vars)) - ;; FIXME: Perhaps BYTE-TRACE-CALLS stuff should be conditional on SB-SHOW. - (when *byte-trace-calls* - (let ((*byte-trace-calls* nil) - (*byte-trace* nil) - (*print-level* sb!debug:*debug-print-level*) - (*print-length* sb!debug:*debug-print-length*) - (sp *eval-stack-top*)) - (format *trace-output* - "~&INVOKE-XEP: ocode= ~S[~D]~% ~ - osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~ - Fun= ~S ~@[~S~]~% Args= ~S~%" - old-component ret-pc old-sp old-fp num-args sp - xep closure-vars (subseq *eval-stack* (- sp num-args) sp)) - (force-output *trace-output*))) - - (let ((entry-point - (cond - ((typep xep 'simple-byte-function) - (unless (eql (simple-byte-function-num-args xep) num-args) - (with-debugger-info (old-component ret-pc old-fp) - (error "wrong number of arguments"))) - (simple-byte-function-entry-point xep)) - (t - (let ((min (hairy-byte-function-min-args xep)) - (max (hairy-byte-function-max-args xep))) - (cond - ((< num-args min) - (with-debugger-info (old-component ret-pc old-fp) - (error "not enough arguments"))) - ((<= num-args max) - (nth (- num-args min) (hairy-byte-function-entry-points xep))) - ((null (hairy-byte-function-more-args-entry-point xep)) - (with-debugger-info (old-component ret-pc old-fp) - (error "too many arguments"))) - (t - (let* ((more-args-supplied (- num-args max)) - (sp *eval-stack-top*) - (more-args-start (- sp more-args-supplied)) - (restp (hairy-byte-function-rest-arg-p xep)) - (rest (and restp - (do ((index (1- sp) (1- index)) - (result nil - (cons (eval-stack-ref index) - result))) - ((< index more-args-start) result) - (declare (fixnum index)))))) - (declare (type index more-args-supplied) - (type stack-pointer more-args-start)) - (cond - ((not (hairy-byte-function-keywords-p xep)) - (aver restp) - (setf *eval-stack-top* (1+ more-args-start)) - (setf (eval-stack-ref more-args-start) rest)) - (t - (unless (evenp more-args-supplied) - (with-debugger-info (old-component ret-pc old-fp) - (error "odd number of &KEY arguments"))) - ;; If there are &KEY args, then we need to leave - ;; the defaulted and supplied-p values where the - ;; more args currently are. There might be more or - ;; fewer. And also, we need to flatten the parsed - ;; args with the defaults before we scan the - ;; keywords. So we copy all the &MORE args to a - ;; temporary area at the end of the stack. - (let* ((num-more-args - (hairy-byte-function-num-more-args xep)) - (new-sp (+ more-args-start num-more-args)) - (temp (max sp new-sp)) - (temp-sp (+ temp more-args-supplied)) - (keywords (hairy-byte-function-keywords xep))) - (declare (type index temp) - (type stack-pointer new-sp temp-sp)) - (allocate-eval-stack (- temp-sp sp)) - (eval-stack-copy temp more-args-start more-args-supplied) - (when restp - (setf (eval-stack-ref more-args-start) rest) - (incf more-args-start)) - (let ((index more-args-start)) - (dolist (keyword keywords) - (setf (eval-stack-ref index) (cadr keyword)) - (incf index) - (when (caddr keyword) - (setf (eval-stack-ref index) nil) - (incf index)))) - (let ((index temp-sp) - (allow (eq (hairy-byte-function-keywords-p xep) - :allow-others)) - (bogus-key nil) - (bogus-key-p nil)) - (declare (type fixnum index)) - (loop - (decf index 2) - (when (< index temp) - (return)) - (let ((key (eval-stack-ref index)) - (value (eval-stack-ref (1+ index)))) - (if (eq key :allow-other-keys) - (setf allow value) - (let ((target more-args-start)) - (declare (type stack-pointer target)) - (dolist (keyword keywords - (setf bogus-key key - bogus-key-p t)) - (cond ((eq (car keyword) key) - (setf (eval-stack-ref target) value) - (when (caddr keyword) - (setf (eval-stack-ref (1+ target)) - t)) - (return)) - ((caddr keyword) - (incf target 2)) - (t - (incf target)))))))) - (when (and bogus-key-p (not allow)) - (with-debugger-info (old-component ret-pc old-fp) - (error "unknown keyword: ~S" bogus-key)))) - (setf *eval-stack-top* new-sp))))) - (hairy-byte-function-more-args-entry-point xep)))))))) - (declare (type pc entry-point)) - (invoke-local-entry-point (byte-function-component xep) entry-point - old-component ret-pc old-sp old-fp - closure-vars))) - -(defun do-return (fp num-results) - (declare (type stack-pointer fp) (type index num-results)) - (let ((old-component (eval-stack-ref (- fp 4)))) - (typecase old-component - (code-component - ;; returning to more byte-interpreted code - (do-local-return old-component fp num-results)) - (null - ;; returning to native code - (let ((old-sp (eval-stack-ref (- fp 2)))) - (case num-results - (0 - (setf *eval-stack-top* old-sp) - (values)) - (1 - (let ((result (pop-eval-stack))) - (setf *eval-stack-top* old-sp) - result)) - (t - (let ((results nil)) - (dotimes (i num-results) - (push (pop-eval-stack) results)) - (setf *eval-stack-top* old-sp) - (values-list results)))))) - (t - ;; ### function end breakpoint? - (error "Function-end breakpoints are not supported."))))) - -(defun do-local-return (old-component fp num-results) - (declare (type stack-pointer fp) (type index num-results)) - (let ((old-fp (eval-stack-ref (- fp 1))) - (old-sp (eval-stack-ref (- fp 2))) - (old-pc (eval-stack-ref (- fp 3)))) - (declare (type (signed-byte 25) old-pc)) - (if (plusp old-pc) - ;; wants single value - (let ((result (if (zerop num-results) - nil - (eval-stack-ref (- *eval-stack-top* - num-results))))) - (setf *eval-stack-top* old-sp) - (push-eval-stack result) - (byte-interpret old-component old-pc old-fp)) - ;; wants multiple values - (progn - (eval-stack-copy old-sp - (- *eval-stack-top* num-results) - num-results) - (setf *eval-stack-top* (+ old-sp num-results)) - (push-eval-stack num-results) - (byte-interpret old-component (- old-pc) old-fp))))) - diff --git a/src/code/byte-types.lisp b/src/code/byte-types.lisp deleted file mode 100644 index e8b85d6..0000000 --- a/src/code/byte-types.lisp +++ /dev/null @@ -1,111 +0,0 @@ -;;;; types which are needed to implement byte-compiled functions - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!C") - -;;;; types - -(deftype stack-pointer () - `(integer 0 ,(1- sb!vm:*target-most-positive-fixnum*))) - -;;; KLUDGE: bare numbers, no documentation, ick.. -- WHN 19990701 -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant max-pc (1- (ash 1 24)))) - -(deftype pc () - `(integer 0 ,max-pc)) - -(deftype return-pc () - `(integer ,(- max-pc) ,max-pc)) - -;;;; byte functions - -;;; This abstract class represents any type of byte-compiled function. -(defstruct (byte-function-or-closure - (:alternate-metaclass funcallable-instance - funcallable-structure-class - make-funcallable-structure-class) - (:type funcallable-structure) - (:constructor nil) - (:copier nil))) - -;;; a byte-compiled closure -(defstruct (byte-closure - (:include byte-function-or-closure) - (:constructor make-byte-closure (function data)) - (:type funcallable-structure) - (:print-object - (lambda (x stream) - (print-unreadable-object (x stream :type t :identity t) - (prin1 (byte-function-name (byte-closure-function x)) - stream)))) - (:copier nil)) - ;; the byte function that we call - (function (required-argument) :type byte-function) - ;; the closure data vector - (data (required-argument) :type simple-vector)) - -;;; any non-closure byte function (including the hidden function -;;; object for a closure) -(defstruct (byte-function (:include byte-function-or-closure) - (:type funcallable-structure) - (:constructor nil) - (:copier nil)) - ;; The component that this XEP is an entry point into. NIL until - ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. They count on this - ;; being the first slot. - (component nil :type (or null code-component)) - ;; Debug name of this function. - (name nil)) -(def!method print-object ((x byte-function) stream) - ;; FIXME: I think functions should probably print either as - ;; # or as #, since those are - ;; their user-visible types. (And this should be true for - ;; BYTE-CLOSURE objects too.) - (print-unreadable-object (x stream :identity t) - (format stream "byte function ~S" (byte-function-name x)))) - -;;; fixed-argument byte function -(defstruct (simple-byte-function (:include byte-function) - (:type funcallable-structure) - (:copier nil)) - ;; The number of arguments expected. - (num-args 0 :type (integer 0 #.call-arguments-limit)) - ;; The start of the function. - (entry-point 0 :type index)) - -;;; variable-arg-count byte function -(defstruct (hairy-byte-function (:include byte-function) - (:type funcallable-structure) - (:copier nil)) - ;; The minimum and maximum number of args, ignoring &REST and &KEY. - (min-args 0 :type (integer 0 #.call-arguments-limit)) - (max-args 0 :type (integer 0 #.call-arguments-limit)) - ;; List of the entry points for min-args, min-args+1, ... max-args. - (entry-points nil :type list) - ;; The entry point to use when there are more than max-args. Only - ;; filled in where okay. In other words, only when &REST or &KEY is - ;; specified. - (more-args-entry-point nil :type (or null (unsigned-byte 24))) - ;; The number of ``more-arg'' args. - (num-more-args 0 :type (integer 0 #.call-arguments-limit)) - ;; True if there is a rest-arg. - (rest-arg-p nil :type (member t nil)) - ;; True if there are keywords. Note: keywords might still be NIL - ;; because having &KEY with no keywords is valid and should result - ;; in &ALLOW-OTHER-KEYS processing. If :ALLOW-OTHERS, then allow - ;; other keys. - (keywords-p nil :type (member t nil :allow-others)) - ;; list of &KEY arguments. Each element is a list of: - ;; key, default, supplied-p. - (keywords nil :type list)) - -#!-sb-fluid (declaim (freeze-type byte-function-or-closure)) diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 254213c..ba361ed 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -1,5 +1,4 @@ -;;;; miscellaneous stuff that needs to be in the cold load which would -;;;; otherwise be byte-compiled +;;;; miscellaneous error stuff that needs to be in the cold load ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. diff --git a/src/code/cold-init-helper-macros.lisp b/src/code/cold-init-helper-macros.lisp index 8a7b9de..6834de7 100644 --- a/src/code/cold-init-helper-macros.lisp +++ b/src/code/cold-init-helper-macros.lisp @@ -52,8 +52,6 @@ (makunbound '*cold-init-forms*))) #+sb-xc-host (declare (ignore name))) -;;; FIXME: These macros should be byte-compiled. - ;;; FIXME: Consider renaming this file asap.lisp, ;;; and the renaming the various things ;;; *ASAP-FORMS* or *REVERSED-ASAP-FORMS* diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index ead055e..99c490e 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -28,9 +28,6 @@ ;;; information for DEF!STRUCT-defined types (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - ;; FIXME: All this could be byte compiled. (Perhaps most of the rest - ;; of the file could be, too.) - ;; (DEF!STRUCT-SUPERTYPE TYPE) is the DEF!STRUCT-defined type that ;; TYPE inherits from, or NIL if none. (defvar *def!struct-supertype* (make-hash-table)) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index c23bb78..2a4e6b6 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -11,9 +11,6 @@ ;;;; files for more information. (in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) - -(declaim #.*optimize-byte-compilation*) - (defvar *describe-indentation-step* 3 #+sb-doc @@ -25,7 +22,6 @@ (defun describe (x &optional (stream-designator *standard-output*)) #+sb-doc "Print a description of the object X." - (declare #.*optimize-external-despite-byte-compilation*) (let ((stream (out-synonym-of stream-designator))) (pprint-logical-block (stream nil) (fresh-line stream) @@ -186,20 +182,9 @@ (%describe-function-name name s (%function-type x)))) (%describe-compiled-from (sb-kernel:function-code-header x) s)) -;;; FIXME: byte compiler to go away completely -#| -(defun %describe-function-byte-compiled (x s kind name) - (declare (type stream s)) - (let ((name (or name (sb-c::byte-function-name x)))) - (%describe-doc name s 'function kind) - (unless (eq kind :macro) - (%describe-function-name name s 'function))) - (%describe-compiled-from (sb-c::byte-function-component x) s)) -|# - ;;; Describe a function with the specified kind and name. The latter ;;; arguments provide some information about where the function came -;;; from. Kind NIL means not from a name. +;;; from. KIND=NIL means not from a name. (defun %describe-function (x s &optional (kind nil) name) (declare (type function x)) (declare (type stream s)) @@ -221,20 +206,6 @@ (%describe-function-compiled x s kind name)) (#.sb-vm:funcallable-instance-header-type (typecase x - ;; FIXME: byte compiler to go away completely - #| - (sb-kernel:byte-function - (%describe-function-byte-compiled x s kind name)) - (sb-kernel:byte-closure - (%describe-function-byte-compiled (byte-closure-function x) - s kind name) - (format s "~@:_Its closure environment is:") - (pprint-logical-block (s nil) - (pprint-indent :current 8) - (let ((data (byte-closure-data x))) - (dotimes (i (length data)) - (format s "~@:_~S: ~S" i (svref data i)))))) - |# (standard-generic-function ;; There should be a special method for this case; we'll ;; delegate to that. diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index cc8dfc3..f2c3adf 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -913,7 +913,6 @@ (t (error "bad option: ~S" (first option))))))))))) `(def!method print-object ((structure ,name) ,stream) - ;; FIXME: should probably be byte-compiled (pprint-logical-block (,stream nil) (print-unreadable-object (structure ,stream diff --git a/src/code/eval.lisp b/src/code/eval.lisp index bca0f12..36531a5 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -12,7 +12,7 @@ (in-package "SB!IMPL") ;;; general case of EVAL (except in that it can't handle toplevel -;;; EVAL-WHEN magic properly): Delegate to the byte compiler. +;;; EVAL-WHEN magic properly): Delegate to #'COMPILE. (defun %eval (expr) (funcall (compile (gensym "EVAL-TMPFUN-") `(lambda () diff --git a/src/code/fop.lisp b/src/code/fop.lisp index aabae17..fe07fe7 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -658,25 +658,6 @@ bug.~:@>") (load-fresh-line) (format t "~S defined~%" fun)) fun))) - -;;; FIXME: byte compiler to be completely deleted -#| -(define-fop (fop-make-byte-compiled-function 143) - (let* ((size (read-arg 1)) - (layout (pop-stack)) - (res (%make-funcallable-instance size layout))) - (declare (type index size)) - (do ((n (1- size) (1- n))) - ((minusp n)) - (declare (type (integer -1 #.most-positive-fixnum) n)) - (setf (%funcallable-instance-info res n) (pop-stack))) - (initialize-byte-compiled-function res) - ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. - #+nil (when *load-print* - (load-fresh-line) - (format t "~S defined~%" res)) - res)) -|# ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code ;;;; was sufficiently stale that the functions it called were no diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index e2f1757..f2ac852 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -847,18 +847,6 @@ (def-alien-type-translator array (ele-type &rest dims &environment env) - ;; This declaration is a workaround for bug 119, which causes the - ;; EVERY #'INTEGERP expression below to be compiled incorrectly - ;; by the byte compiler. Since as of sbcl-0.pre7.x we are using - ;; the byte compiler to do all the tricky stuff for the 'interpreter', - ;; and since we use 'interpreted' definitions of these type translators - ;; at cross-compilation time, this means that cross-compilation - ;; doesn't work properly unless we force this function to be - ;; native compiled instead of byte-compiled. - ;; - ;; FIXME: So, when bug 119 is fixed, this declaration can go away. - (declare (optimize (speed 2))) ; i.e. not byte-compiled - (when dims (unless (typep (first dims) '(or index null)) (error "The first dimension is not a non-negative fixnum or NIL: ~S" diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index 71a0761..db51e0f 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -11,8 +11,6 @@ (in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) -(declaim #.*optimize-byte-compilation*) - (defparameter *inspect-length* 10) ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it @@ -20,7 +18,6 @@ (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")) (defun inspect (object) - (declare #.*optimize-external-despite-byte-compilation*) (catch 'quit-inspect (%inspect object *standard-output*)) (values)) diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 6d86938..040bd05 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -67,81 +67,6 @@ #!-x86 (def-math-rtn "sqrt" 1) (def-math-rtn "hypot" 2) #!-(or hpux x86) (def-math-rtn "log1p" 1) - -#!+x86 ;; These are needed for use by byte-compiled files. -(progn - (defun %sin (x) - (declare (double-float x) - (values double-float)) - (%sin x)) - (defun %sin-quick (x) - (declare (double-float x) - (values double-float)) - (%sin-quick x)) - (defun %cos (x) - (declare (double-float x) - (values double-float)) - (%cos x)) - (defun %cos-quick (x) - (declare (double-float x) - (values double-float)) - (%cos-quick x)) - (defun %tan (x) - (declare (double-float x) - (values double-float)) - (%tan x)) - (defun %tan-quick (x) - (declare (double-float x) - (values double-float)) - (%tan-quick x)) - (defun %atan (x) - (declare (double-float x) - (values double-float)) - (%atan x)) - (defun %atan2 (x y) - (declare (double-float x y) - (values double-float)) - (%atan2 x y)) - (defun %exp (x) - (declare (double-float x) - (values double-float)) - (%exp x)) - (defun %log (x) - (declare (double-float x) - (values double-float)) - (%log x)) - (defun %log10 (x) - (declare (double-float x) - (values double-float)) - (%log10 x)) - #+nil ;; notyet - (defun %pow (x y) - (declare (type (double-float 0d0) x) - (double-float y) - (values (double-float 0d0))) - (%pow x y)) - (defun %sqrt (x) - (declare (double-float x) - (values double-float)) - (%sqrt x)) - (defun %scalbn (f ex) - (declare (double-float f) - (type (signed-byte 32) ex) - (values double-float)) - (%scalbn f ex)) - (defun %scalb (f ex) - (declare (double-float f ex) - (values double-float)) - (%scalb f ex)) - (defun %logb (x) - (declare (double-float x) - (values double-float)) - (%logb x)) - (defun %log1p (x) - (declare (double-float x) - (values double-float)) - (%log1p x)) - ) ; progn ;;;; power functions diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 500ac97..9653bd5 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -240,7 +240,6 @@ ;;; Profile the named function, which should exist and not be profiled ;;; already. (defun profile-1-unprofiled-function (name) - (declare #.*optimize-byte-compilation*) (let ((encapsulated-fun (fdefinition name))) (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun) (profile-encapsulation-lambdas encapsulated-fun) @@ -256,7 +255,6 @@ ;;; Profile the named function. If already profiled, unprofile first. (defun profile-1-function (name) - (declare #.*optimize-byte-compilation*) (cond ((fboundp name) (when (gethash name *profiled-function-name->info*) (warn "~S is already profiled, so unprofiling it first." name) @@ -268,7 +266,6 @@ ;;; Unprofile the named function, if it is profiled. (defun unprofile-1-function (name) - (declare #.*optimize-byte-compilation*) (let ((pinfo (gethash name *profiled-function-name->info*))) (cond (pinfo (remhash name *profiled-function-name->info*) @@ -293,7 +290,6 @@ reprofile (useful to notice function redefinition.) If a name is undefined, then we give a warning and ignore it. See also UNPROFILE, REPORT and RESET." - (declare #.*optimize-byte-compilation*) (if (null names) `(loop for k being each hash-key in *profiled-function-name->info* collecting k) @@ -306,13 +302,11 @@ a function. A string names all the functions named by symbols in the named package. NAMES defaults to the list of names of all currently profiled functions." - (declare #.*optimize-byte-compilation*) (if names `(mapc-on-named-functions #'unprofile-1-function ',names) `(unprofile-all))) (defun unprofile-all () - (declare #.*optimize-byte-compilation*) (dohash (name profile-info *profiled-function-name->info*) (declare (ignore profile-info)) (unprofile-1-function name))) @@ -357,7 +351,6 @@ for profiling overhead. The compensation may be rather inaccurate when bignums are involved in runtime calculation, as in a very-long-running Lisp process." - (declare #.*optimize-external-despite-byte-compilation*) (unless (boundp '*overhead*) (setf *overhead* (compute-overhead))) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index e4fdf4a..edcd08c 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1949,6 +1949,26 @@ ;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We don't ;;; bother to worry about optimizing them. ;;; +;;; (Except note that on Sat, Oct 06, 2001 at 04:22:38PM +0100, +;;; Christophe Rhodes wrote on sbcl-devel +;;; +;;; My understanding is that while the :test-not argument is +;;; deprecated in favour of :test (complement #'foo) because of +;;; semantic difficulties (what happens if both :test and :test-not +;;; are supplied, etc) the -if-not variants, while officially +;;; deprecated, would be undeprecated were X3J13 actually to produce +;;; a revised standard, as there are perfectly legitimate idiomatic +;;; reasons for allowing the -if-not versions equal status, +;;; particularly remove-if-not (== filter). +;;; +;;; This is only an informal understanding, I grant you, but +;;; perhaps it's worth optimizing the -if-not versions in the same +;;; way as the others? +;;; +;;; That sounds reasonable, so if someone wants to submit patches to +;;; make the -IF-NOT functions compile as efficiently as the +;;; corresponding -IF variants do, go for it. -- WHN 2001-10-06) +;;; ;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT ;;; too) within the implementation of SBCL. (macrolet ((def-find-position-if-not (fun-name values-index) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 9af080e..93c9beb 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -123,9 +123,9 @@ ;;; both the code pointer and the lexenv, since that code pointer (for ;;; an instance-lambda) is expecting that lexenv to be accessed. This ;;; effectively pre-flattens what would otherwise be a chain of -;;; indirections. Lest this sound like an excessively obscure case, -;;; note that it happens when PCL dispatch functions are -;;; byte-compiled. +;;; indirections. (That used to happen when PCL dispatch functions +;;; were byte-compiled; now that the byte compiler is gone, I can't +;;; think of another example offhand. -- WHN 2001-10-06) ;;; ;;; The only loss is that if someone accesses the ;;; FUNCALLABLE-INSTANCE-FUNCTION, then won't get a FIN back. This diff --git a/src/code/target-extensions.lisp b/src/code/target-extensions.lisp index adf1f84..7b13df4 100644 --- a/src/code/target-extensions.lisp +++ b/src/code/target-extensions.lisp @@ -69,29 +69,3 @@ :format-control "~@<~A: ~2I~_~A~:>" :format-arguments (list prefix-string (strerror errno)) other-condition-args)) - -;;;; optimization idioms - -(eval-when (:compile-toplevel :load-toplevel :execute) - - ;; Byte compile this thing if possible. - (defvar *optimize-byte-compilation* - '(optimize (speed 0) (safety 1))) - - ;; This thing is externally visible, so compiling meta-information - ;; is more important than byte-compiling it; but it's otherwise - ;; suitable for byte-compilation. - ;; - ;; (As long as the byte compiler isn't capable of compiling - ;; meta-information such as the argument list required by functions - ;; (as in sbcl-0.6.12, anyway), it's not suitable for compiling - ;; externally visible things like CL:INSPECT even if their speed - ;; requirements are small enough that it'd otherwise be OK. If some - ;; later version of the byte compiler learns to compile such - ;; meta-information, we'll probably change the implementation of - ;; this idiom so that it causes byte compilation of the thing after - ;; all.) - (defvar *optimize-external-despite-byte-compilation* - '(optimize (speed 1) - ;; still might as well be as small as possible.. - (space 3)))) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 701f8a0..4bfa055 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -642,9 +642,7 @@ ;;; not only parts of the system which are defined after DEFUN MAPHASH. ;;; 2. It could be conditional on compilation policy, so that ;;; it could be compiled as a full call instead of an inline -;;; expansion when SPACE>SPEED. (Not only would this save space, -;;; it might actually be faster when a call is made from byte-compiled -;;; code.) +;;; expansion when SPACE>SPEED. (declaim (inline maphash)) (defun maphash (function-designator hash-table) #!+sb-doc diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index c2df8ae..0c8e9b6 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -246,9 +246,6 @@ ;;; all these code objects. After a purify these fixups can be ;;; dropped. In CMU CL, this policy was enabled with ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used. -;;; -;;; A little analysis of the header information is used to determine -;;; if a code object is byte compiled, or native code. #!+x86 (defun load-code (box-num code-length) (declare (fixnum box-num code-length)) @@ -268,15 +265,6 @@ (setq stuff (nreverse stuff)) - ;; Check that tto is always a list for byte-compiled - ;; code. Could be used an alternate check. - (when (and (typep tto 'list) - (not (and (sb!c::debug-info-p dbi) - (not (sb!c::compiled-debug-info-p dbi))))) - ;; FIXME: What is this for? - (format t "* tto list on non-bc code: ~S~% ~S ~S~%" - stuff dbi tto)) - ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW. (when *load-code-verbose* (format t "stuff: ~S~%" stuff) diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index e5680f5..5ea1f53 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -23,17 +23,8 @@ ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type) (%function-name x)) (#.sb!vm:funcallable-instance-header-type - (typecase x - ;; FIXME: byte compiler to go away completely - #| - (byte-function - (sb!c::byte-function-name x)) - (byte-closure - (sb!c::byte-function-name (byte-closure-function x))) - |# - (t ;; funcallable-instance - (%function-name - (funcallable-instance-function x)))))))) + (%function-name + (funcallable-instance-function x)))))) (when (and name (typep name '(or symbol cons))) (values (info :function :documentation name))))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index be3cbd1..40a9576 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -860,9 +860,6 @@ ;;;; APROPOS and APROPOS-LIST -;;; KLUDGE: All the APROPOS stuff should probably be byte-compiled, since it's -;;; only likely to be used interactively. -- WHN 19990827 - (defun briefly-describe-symbol (symbol) (fresh-line) (prin1 symbol) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index a3ec9c6..1bd5d47 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -128,14 +128,7 @@ ;;; Pull the type specifier out of a function object. (defun extract-function-type (fun) - (typecase fun - ;; FIXME: byte compiler to be deleted completely - #| - (byte-function (byte-function-type fun)) - (byte-closure (byte-function-type (byte-closure-function fun))) - |# - (t - (specifier-type (%function-type (%closure-function fun)))))) + (specifier-type (%function-type (%closure-function fun)))) ;;;; miscellaneous interfaces diff --git a/src/code/time.lisp b/src/code/time.lisp index 9ae42fc..ac20fce 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -234,19 +234,9 @@ (defmacro time (form) #!+sb-doc - "Evaluates the Form and prints timing information on *Trace-Output*." + "Execute FORM and print timing information on *TRACE-OUTPUT*." `(%time #'(lambda () ,form))) -;;; Try to compile the closure arg to %TIME if it is interpreted. -(defun massage-time-function (fun) - ;; This is just a placeholder as of the switch from IR1 interpreter - ;; to bytecode interpreter. Someday it might make sense to complain - ;; about bytecoded FUN and/or compile it to native code, so I've - ;; left the placeholder in place, but as of sbcl-0.7.0 it's not - ;; obvious how to do the right thing easily, so I haven't actually - ;; done it. -- WHN - fun) - ;;; Return all the data that we want TIME to report. (defun time-get-sys-info () (multiple-value-bind (user sys faults) (sb!sys:get-system-info) @@ -255,8 +245,7 @@ ;;; The guts of the TIME macro. Compute overheads, run the (compiled) ;;; function, report the times. (defun %time (fun) - (let ((fun (massage-time-function fun)) - old-run-utime + (let (old-run-utime new-run-utime old-run-stime new-run-stime diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index d6aee3a..2b28531 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -234,8 +234,6 @@ ;;;; the default toplevel function -;;; FIXME: Most stuff below here can probably be byte-compiled. - (defvar / nil #!+sb-doc "a list of all the values returned by the most recent top-level EVAL") diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 353e1d8..e6fd45f 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -338,7 +338,7 @@ ;;; Support for the MT19937 random number generator. The update ;;; function is implemented as an assembly routine. This definition is ;;; transformed to a call to the assembly routine allowing its use in -;;; byte compiled code. +;;; interpreted code. (defun random-mt19937 (state) (declare (type (simple-array (unsigned-byte 32) (627)) state)) (random-mt19937 state)) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 70d8c95..2ace156 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -46,9 +46,9 @@ ;; (Hopefully this will go away as we move the files above into cold load.) ;; -- WHN 19991214 (let ((fullname (concatenate 'string stem ".lisp"))) - ;; (Now that we use the byte compiler for interpretation, - ;; /SHOW doesn't get compiled properly until the src/assembly - ;; files have been loaded.) + ;; (Now that we use byte compiler for interpretation, /SHOW + ;; doesn't get compiled properly until the src/assembly files have + ;; been loaded, so we use PRINT instead.) #+sb-show (print "/about to compile src/assembly file") #+sb-show (print fullname) (multiple-value-bind diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 1224c85..be3da29 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -142,30 +142,26 @@ ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the ;;; elements. (def-source-transform vector (&rest elements) - (if (byte-compiling) - (values nil t) - (let ((len (length elements)) - (n -1)) - (once-only ((n-vec `(make-array ,len))) - `(progn - ,@(mapcar #'(lambda (el) - (once-only ((n-val el)) - `(locally (declare (optimize (safety 0))) - (setf (svref ,n-vec ,(incf n)) - ,n-val)))) - elements) - ,n-vec))))) + (let ((len (length elements)) + (n -1)) + (once-only ((n-vec `(make-array ,len))) + `(progn + ,@(mapcar #'(lambda (el) + (once-only ((n-val el)) + `(locally (declare (optimize (safety 0))) + (setf (svref ,n-vec ,(incf n)) + ,n-val)))) + elements) + ,n-vec)))) ;;; Just convert it into a MAKE-ARRAY. (def-source-transform make-string (length &key (element-type ''base-char) (initial-element '#.*default-init-char-form*)) - (if (byte-compiling) - (values nil t) - `(make-array (the index ,length) - :element-type ,element-type - :initial-element ,initial-element))) + `(make-array (the index ,length) + :element-type ,element-type + :initial-element ,initial-element)) (defstruct (specialized-array-element-type-properties (:conc-name saetp-) @@ -600,13 +596,9 @@ (macrolet ((define-frob (reffer setter type) `(progn (def-source-transform ,reffer (a &rest i) - (if (byte-compiling) - (values nil t) - `(aref (the ,',type ,a) ,@i))) + `(aref (the ,',type ,a) ,@i)) (def-source-transform ,setter (a &rest i) - (if (byte-compiling) - (values nil t) - `(%aset (the ,',type ,a) ,@i)))))) + `(%aset (the ,',type ,a) ,@i))))) (define-frob svref %svset simple-vector) (define-frob schar %scharset simple-string) (define-frob char %charset string) diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp deleted file mode 100644 index 528a3ff..0000000 --- a/src/compiler/byte-comp.lisp +++ /dev/null @@ -1,2012 +0,0 @@ -;;;; that part of the byte compiler which exists not only in the -;;;; target Lisp, but also in the cross-compilation host Lisp - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!C") - -;;; ### remaining work: -;;; -;;; - add more inline operations. -;;; - Breakpoints/debugging info. - -;;;; stuff to emit noise - -;;; Note: We use the regular assembler, but we don't use any -;;; ``instructions'' because there is no way to keep our byte-code -;;; instructions separate from the instructions used by the native -;;; backend. Besides, we don't want to do any scheduling or anything -;;; like that, anyway. - -#!-sb-fluid (declaim (inline output-byte)) -(defun output-byte (segment byte) - (declare (type sb!assem:segment segment) - (type (unsigned-byte 8) byte)) - (sb!assem:emit-byte segment byte)) - -;;; Output OPERAND as 1 or 4 bytes, using #xFF as the extend code. -(defun output-extended-operand (segment operand) - (declare (type (unsigned-byte 24) operand)) - (cond ((<= operand 254) - (output-byte segment operand)) - (t - (output-byte segment #xFF) - (output-byte segment (ldb (byte 8 16) operand)) - (output-byte segment (ldb (byte 8 8) operand)) - (output-byte segment (ldb (byte 8 0) operand))))) - -;;; Output a byte, logior'ing in a 4 bit immediate constant. If that -;;; immediate won't fit, then emit it as the next 1-4 bytes. -(defun output-byte-with-operand (segment byte operand) - (declare (type sb!assem:segment segment) - (type (unsigned-byte 8) byte) - (type (unsigned-byte 24) operand)) - (cond ((<= operand 14) - (output-byte segment (logior byte operand))) - (t - (output-byte segment (logior byte 15)) - (output-extended-operand segment operand))) - (values)) - -(defun output-label (segment label) - (declare (type sb!assem:segment segment) - (type sb!assem:label label)) - (sb!assem:assemble (segment) - (sb!assem:emit-label label))) - -;;; Output a reference to LABEL. -(defun output-reference (segment label) - (declare (type sb!assem:segment segment) - (type sb!assem:label label)) - (sb!assem:emit-back-patch - segment - 3 - #'(lambda (segment posn) - (declare (type sb!assem:segment segment) - (ignore posn)) - (let ((target (sb!assem:label-position label))) - (aver (<= 0 target (1- (ash 1 24)))) - (output-byte segment (ldb (byte 8 16) target)) - (output-byte segment (ldb (byte 8 8) target)) - (output-byte segment (ldb (byte 8 0) target)))))) - -;;; Output some branch byte-sequence. -(defun output-branch (segment kind label) - (declare (type sb!assem:segment segment) - (type (unsigned-byte 8) kind) - (type sb!assem:label label)) - (sb!assem:emit-chooser - segment 4 1 - #'(lambda (segment posn delta) - (when (<= (- (ash 1 7)) - (- (sb!assem:label-position label posn delta) posn 2) - (1- (ash 1 7))) - (sb!assem:emit-chooser - segment 2 1 - #'(lambda (segment posn delta) - (declare (ignore segment) (type index posn delta)) - (when (zerop (- (sb!assem:label-position label posn delta) - posn 2)) - ;; Don't emit anything, because the branch is to the following - ;; instruction. - t)) - #'(lambda (segment posn) - ;; We know that we fit in one byte. - (declare (type sb!assem:segment segment) - (type index posn)) - (output-byte segment (logior kind 1)) - (output-byte segment - (ldb (byte 8 0) - (- (sb!assem:label-position label) posn 2))))) - t)) - #'(lambda (segment posn) - (declare (type sb!assem:segment segment) - (ignore posn)) - (let ((target (sb!assem:label-position label))) - (aver (<= 0 target (1- (ash 1 24)))) - (output-byte segment kind) - (output-byte segment (ldb (byte 8 16) target)) - (output-byte segment (ldb (byte 8 8) target)) - (output-byte segment (ldb (byte 8 0) target)))))) - -;;;; system constants, Xops, and inline functions - -;;; If (%FDEFINITION-MARKER% . NAME) is a key in the table, then the -;;; corresponding value is the byte code fdefinition. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *system-constant-codes* (make-hash-table :test 'equal))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (flet ((def-system-constant (index form) - (setf (gethash form *system-constant-codes*) index))) - (def-system-constant 0 nil) - (def-system-constant 1 t) - (def-system-constant 2 :start) - (def-system-constant 3 :end) - (def-system-constant 4 :test) - (def-system-constant 5 :count) - (def-system-constant 6 :test-not) - (def-system-constant 7 :key) - (def-system-constant 8 :from-end) - (def-system-constant 9 :type) - (def-system-constant 10 '(%fdefinition-marker% . error)) - (def-system-constant 11 '(%fdefinition-marker% . format)) - (def-system-constant 12 '(%fdefinition-marker% . %typep)) - (def-system-constant 13 '(%fdefinition-marker% . eql)) - (def-system-constant 14 '(%fdefinition-marker% . %negate)) - ;; (15 was %%DEFUN, no longer used as of sbcl-0.pre7.) - (def-system-constant 16 '(%fdefinition-marker% . %%defmacro)) - ;; (17 was %%DEFCONSTANT, no longer used as of sbcl-0.pre7.) - (def-system-constant 18 '(%fdefinition-marker% . length)) - (def-system-constant 19 '(%fdefinition-marker% . equal)) - (def-system-constant 20 '(%fdefinition-marker% . append)) - (def-system-constant 21 '(%fdefinition-marker% . reverse)) - (def-system-constant 22 '(%fdefinition-marker% . nreverse)) - (def-system-constant 23 '(%fdefinition-marker% . nconc)) - (def-system-constant 24 '(%fdefinition-marker% . list)) - (def-system-constant 25 '(%fdefinition-marker% . list*)) - (def-system-constant 26 '(%fdefinition-marker% . %coerce-name-to-function)) - (def-system-constant 27 '(%fdefinition-marker% . values-list)))) - -(eval-when (#+sb-xc :compile-toplevel :load-toplevel :execute) - -(defparameter *xop-names* - '(breakpoint; 0 - dup; 1 - type-check; 2 - fdefn-function-or-lose; 3 - default-unknown-values; 4 - push-n-under; 5 - xop6 - xop7 - merge-unknown-values - make-closure - throw - catch - breakup - return-from - tagbody - go - unwind-protect)) - -(defun xop-index-or-lose (name) - (or (position name *xop-names* :test #'eq) - (error "unknown XOP ~S" name))) - -) ; EVAL-WHEN - -;;; FIXME: The hardwired 32 here (found also in (MOD 32) above, and in -;;; the number of bits tested in EXPAND-INTO-INLINES, and perhaps -;;; elsewhere) is ugly. There should be some symbolic constant for the -;;; number of bits devoted to coding byte-inline functions. -(eval-when (:compile-toplevel :load-toplevel :execute) - - (defstruct (inline-function-info (:copier nil)) - ;; the name of the function that we convert into calls to this - (function (required-argument) :type symbol) - ;; the name of the function that the interpreter should call to - ;; implement this. This may not be the same as the FUNCTION slot - ;; value if extra safety checks are required. - (interpreter-function (required-argument) :type symbol) - ;; the inline operation number, i.e. the byte value actually - ;; written into byte-compiled code - (number (required-argument) :type (mod 32)) - ;; the type that calls must satisfy - (type (required-argument) :type function-type) - ;; Can we skip type checking of the arguments? - (safe (required-argument) :type boolean)) - - (defparameter *inline-functions* (make-array 32 :initial-element nil)) - (defparameter *inline-function-table* (make-hash-table :test 'eq)) - (let ((number 0)) - (dolist (stuff - '((+ (fixnum fixnum) fixnum) - (- (fixnum fixnum) fixnum) - (make-value-cell (t) t) - (value-cell-ref (t) t) - (value-cell-setf (t t) (values)) - (symbol-value (symbol) t - :interpreter-function %byte-symbol-value) - (setf-symbol-value (t symbol) (values)) - (%byte-special-bind (t symbol) (values)) - (%byte-special-unbind () (values)) - (%negate (fixnum) fixnum) - (< (fixnum fixnum) t) - (> (fixnum fixnum) t) - (car (t) t :interpreter-function %byte-car :safe t) - (cdr (t) t :interpreter-function %byte-cdr :safe t) - (length (list) t) - (cons (t t) t) - (list (t t) t) - (list* (t t t) t) - (%instance-ref (t t) t) - (%setf-instance-ref (t t t) (values)))) - (destructuring-bind - (name arg-types result-type - &key (interpreter-function name) alias safe) - stuff - (let ((info - (make-inline-function-info - :function name - :number number - :interpreter-function interpreter-function - :type (specifier-type `(function ,arg-types ,result-type)) - :safe safe))) - (setf (svref *inline-functions* number) info) - (setf (gethash name *inline-function-table*) info)) - (unless alias (incf number)))))) - -(defun inline-function-number-or-lose (function) - (let ((info (gethash function *inline-function-table*))) - (if info - (inline-function-info-number info) - (error "unknown inline function: ~S" function)))) - -;;;; transforms which are specific to byte code - -;;; It appears that the idea here is that in byte code, EQ is more -;;; efficient than CHAR=. -- WHN 199910 - -(deftransform eql ((x y) ((or fixnum character) (or fixnum character)) - * :when :byte) - '(eq x y)) - -(deftransform char= ((x y) * * :when :byte) - '(eq x y)) - -;;;; annotations hung off the IR1 while compiling - -(defstruct (byte-component-info (:copier nil)) - (constants (make-array 10 :adjustable t :fill-pointer 0))) - -(defstruct (byte-lambda-info (:copier nil)) - (label nil :type (or null label)) - (stack-size 0 :type index) - ;; FIXME: should be INTERESTING-P T :TYPE BOOLEAN - (interesting t :type (member t nil))) - -(defun block-interesting (block) - (byte-lambda-info-interesting (lambda-info (block-home-lambda block)))) - -(defstruct (byte-lambda-var-info (:copier nil)) - (argp nil :type (member t nil)) - (offset 0 :type index)) - -(defstruct (byte-nlx-info (:copier nil)) - (stack-slot nil :type (or null index)) - (label (sb!assem:gen-label) :type sb!assem:label) - (duplicate nil :type (member t nil))) - -(defstruct (byte-block-info - (:copier nil) - (:include block-annotation) - (:constructor make-byte-block-info - (block &key produces produces-sset consumes - total-consumes nlx-entries nlx-entry-p))) - (label (sb!assem:gen-label) :type sb!assem:label) - ;; A list of the CONTINUATIONs describing values that this block - ;; pushes onto the stack. Note: PRODUCES and CONSUMES can contain - ;; the keyword :NLX-ENTRY marking the place on the stack where a - ;; non-local-exit frame is added or removed. Since breaking up a NLX - ;; restores the stack, we don't have to about (and in fact must not) - ;; discard values underneath a :NLX-ENTRY marker evern though they - ;; appear to be dead (since they might not be.) - (produces nil :type list) - ;; An SSET of the produces for faster set manipulations. The - ;; elements are the BYTE-CONTINUATION-INFO objects. :NLX-ENTRY - ;; markers are not represented. - (produces-sset (make-sset) :type sset) - ;; A list of the continuations that this block pops from the stack. - ;; See PRODUCES. - (consumes nil :type list) - ;; The transitive closure of what this block and all its successors - ;; consume. After stack-analysis, that is. - (total-consumes (make-sset) :type sset) - ;; Set to T whenever the consumes lists of a successor changes and - ;; the block is queued for re-analysis so we can easily avoid - ;; queueing the same block several times. - (already-queued nil :type (member t nil)) - ;; The continuations and :NLX-ENTRY markers on the stack (in order) - ;; when this block starts. - (start-stack :unknown :type (or (member :unknown) list)) - ;; The continuations and :NLX-ENTRY markers on the stack (in order) - ;; when this block ends. - (end-stack nil :type list) - ;; List of ((nlx-info*) produces consumes) for each ENTRY in this - ;; block that is a NLX target. - (nlx-entries nil :type list) - ;; T if this is an %nlx-entry point, and we shouldn't just assume we - ;; know what is going to be on the stack. - (nlx-entry-p nil :type (member t nil))) - -(defprinter (byte-block-info) - block) - -(defstruct (byte-continuation-info - (:include sset-element) - (:constructor make-byte-continuation-info - (continuation results placeholders)) - (:copier nil)) - (continuation (required-argument) :type continuation) - (results (required-argument) - :type (or (member :fdefinition :eq-test :unknown) index)) - ;; If the DEST is a local non-MV call, then we may need to push some - ;; number of placeholder args corresponding to deleted - ;; (unreferenced) args. If PLACEHOLDERS /= 0, then RESULTS is - ;; PLACEHOLDERS + 1. - (placeholders (required-argument) :type index)) - -(defprinter (byte-continuation-info) - continuation - results - (placeholders :test (/= placeholders 0))) - -;;;; Annotate the IR1. - -(defun annotate-continuation (cont results &optional (placeholders 0)) - ;; For some reason, DO-NODES does the same return node multiple - ;; times, which causes ANNOTATE-CONTINUATION to be called multiple - ;; times on the same continuation. So we can't assert that we - ;; haven't done it. - #+nil - (aver (null (continuation-info cont))) - (setf (continuation-info cont) - (make-byte-continuation-info cont results placeholders)) - (values)) - -(defun annotate-set (set) - ;; Annotate the value for one value. - (annotate-continuation (set-value set) 1)) - -;;; We do different stack magic for non-MV and MV calls to figure out -;;; how many values should be pushed during compilation of each arg. -;;; -;;; Since byte functions are directly caller by the interpreter (there -;;; is no XEP), and it doesn't know which args are actually used, byte -;;; functions must allow unused args to be passed. But this creates a -;;; problem with local calls, because these unused args would not -;;; otherwise be pushed (since the continuation has been deleted.) So, -;;; in this function, we count up placeholders for any unused args -;;; contiguously preceding this one. These placeholders are inserted -;;; under the referenced arg by CHECKED-CANONICALIZE-VALUES. -;;; -;;; With MV calls, we try to figure out how many values are actually -;;; generated. We allow initial args to supply a fixed number of -;;; values, but everything after the first :unknown arg must also be -;;; unknown. This picks off most of the standard uses (i.e. calls to -;;; apply), but still is easy to implement. -(defun annotate-basic-combination-args (call) - (declare (type basic-combination call)) - (etypecase call - (combination - (if (and (eq (basic-combination-kind call) :local) - (member (functional-kind (combination-lambda call)) - '(nil :optional :cleanup))) - (let ((placeholders 0)) - (declare (type index placeholders)) - (dolist (arg (combination-args call)) - (cond (arg - (annotate-continuation arg (1+ placeholders) placeholders) - (setq placeholders 0)) - (t - (incf placeholders))))) - (dolist (arg (combination-args call)) - (when arg - (annotate-continuation arg 1))))) - (mv-combination - (labels - ((allow-fixed (remaining) - (when remaining - (let* ((cont (car remaining)) - (values (nth-value 1 - (values-types - (continuation-derived-type cont))))) - (cond ((eq values :unknown) - (force-to-unknown remaining)) - (t - (annotate-continuation cont values) - (allow-fixed (cdr remaining))))))) - (force-to-unknown (remaining) - (when remaining - (let ((cont (car remaining))) - (when cont - (annotate-continuation cont :unknown))) - (force-to-unknown (cdr remaining))))) - (allow-fixed (mv-combination-args call))))) - (values)) - -(defun annotate-local-call (call) - (cond ((mv-combination-p call) - (annotate-continuation - (first (basic-combination-args call)) - (length (lambda-vars (combination-lambda call))))) - (t - (annotate-basic-combination-args call) - (when (member (functional-kind (combination-lambda call)) - '(nil :optional :cleanup)) - (dolist (arg (basic-combination-args call)) - (when arg - (setf (continuation-%type-check arg) nil)))))) - (annotate-continuation (basic-combination-fun call) 0) - (when (node-tail-p call) - (set-tail-local-call-successor call))) - -;;; Annotate the values for any :full combination. This includes -;;; inline functions, multiple value calls & throw. If a real full -;;; call or a safe inline operation, then clear any type-check -;;; annotations. When we are done, remove jump to return for tail -;;; calls. -;;; -;;; Also, we annotate slot accessors as inline if no type check is -;;; needed and (for setters) no value needs to be left on the stack. -(defun annotate-full-call (call) - (let* ((fun (basic-combination-fun call)) - (args (basic-combination-args call)) - (name (continuation-function-name fun)) - (info (gethash name *inline-function-table*))) - (flet ((annotate-args () - (annotate-basic-combination-args call) - (dolist (arg args) - (when (continuation-type-check arg) - (setf (continuation-%type-check arg) :deleted))) - (annotate-continuation - fun - (if (continuation-function-name fun) :fdefinition 1)))) - (cond ((mv-combination-p call) - (cond ((eq name '%throw) - (aver (= (length args) 2)) - (annotate-continuation (first args) 1) - (annotate-continuation (second args) :unknown) - (setf (node-tail-p call) nil) - (annotate-continuation fun 0)) - (t - (annotate-args)))) - ((and info - (valid-function-use call (inline-function-info-type info))) - (annotate-basic-combination-args call) - (setf (node-tail-p call) nil) - (setf (basic-combination-info call) info) - (annotate-continuation fun 0) - (when (inline-function-info-safe info) - (dolist (arg args) - (when (continuation-type-check arg) - (setf (continuation-%type-check arg) :deleted))))) - ((and name - (let ((leaf (ref-leaf (continuation-use fun)))) - (and (slot-accessor-p leaf) - (or (policy call (zerop safety)) - (not (find t args - :key #'continuation-type-check))) - (if (consp name) - (not (continuation-dest (node-cont call))) - t)))) - (setf (basic-combination-info call) - (gethash (if (consp name) '%setf-instance-ref '%instance-ref) - *inline-function-table*)) - (setf (node-tail-p call) nil) - (annotate-continuation fun 0) - (annotate-basic-combination-args call)) - (t - (annotate-args))))) - - ;; If this is (still) a tail-call, then blow away the return. - (when (node-tail-p call) - (node-ends-block call) - (let ((block (node-block call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block))))) - - (values)) - -(defun annotate-known-call (call) - (annotate-basic-combination-args call) - (setf (node-tail-p call) nil) - (annotate-continuation (basic-combination-fun call) 0) - t) - -(defun annotate-basic-combination (call) - ;; Annotate the function. - (let ((kind (basic-combination-kind call))) - (case kind - (:local - (annotate-local-call call)) - (:full - (annotate-full-call call)) - (:error - (setf (basic-combination-kind call) :full) - (annotate-full-call call)) - (t - (unless (and (function-info-byte-compile kind) - (funcall (or (function-info-byte-annotate kind) - #'annotate-known-call) - call)) - (setf (basic-combination-kind call) :full) - (annotate-full-call call))))) - - (values)) - -(defun annotate-if (if) - ;; Annotate the test. - (let* ((cont (if-test if)) - (use (continuation-use cont))) - (annotate-continuation - cont - (if (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) 'eq) - (= (length (combination-args use)) 2)) - ;; If the test is a call to EQ, then we can use branch-if-eq - ;; so don't need to actually funcall the test. - :eq-test - ;; Otherwise, funcall the test for 1 value. - 1)))) - -(defun annotate-return (return) - (let ((cont (return-result return))) - (annotate-continuation - cont - (nth-value 1 (values-types (continuation-derived-type cont)))))) - -(defun annotate-exit (exit) - (let ((cont (exit-value exit))) - (when cont - (annotate-continuation cont :unknown)))) - -(defun annotate-block (block) - (do-nodes (node cont block) - (etypecase node - (bind) - (ref) - (cset (annotate-set node)) - (basic-combination (annotate-basic-combination node)) - (cif (annotate-if node)) - (creturn (annotate-return node)) - (entry) - (exit (annotate-exit node)))) - (values)) - -(defun annotate-ir1 (component) - (do-blocks (block component) - (when (block-interesting block) - (annotate-block block))) - (values)) - -;;;; stack analysis - -(defvar *byte-continuation-counter*) - -;;; Scan the nodes in BLOCK and compute the information that we will -;;; need to do flow analysis and our stack simulation walk. We simulate -;;; the stack within the block, reducing it to ordered lists -;;; representing the values we remove from the top of the stack and -;;; place on the stack (not considering values that are produced and -;;; consumed within the block.) A NLX entry point is considered to -;;; push a :NLX-ENTRY marker (can be though of as the run-time catch -;;; frame.) -(defun compute-produces-and-consumes (block) - (let ((stack nil) - (consumes nil) - (total-consumes (make-sset)) - (nlx-entries nil) - (nlx-entry-p nil)) - (labels ((interesting (cont) - (and cont - (let ((info (continuation-info cont))) - (and info - (not (member (byte-continuation-info-results info) - '(0 :eq-test))))))) - (consume (cont) - (cond ((not (or (eq cont :nlx-entry) (interesting cont)))) - (stack - (aver (eq (car stack) cont)) - (pop stack)) - (t - (adjoin-cont cont total-consumes) - (push cont consumes)))) - (adjoin-cont (cont sset) - (unless (eq cont :nlx-entry) - (let ((info (continuation-info cont))) - (unless (byte-continuation-info-number info) - (setf (byte-continuation-info-number info) - (incf *byte-continuation-counter*))) - (sset-adjoin info sset))))) - (do-nodes (node cont block) - (etypecase node - (bind) - (ref) - (cset - (consume (set-value node))) - (basic-combination - (dolist (arg (reverse (basic-combination-args node))) - (when arg - (consume arg))) - (consume (basic-combination-fun node)) - (case (continuation-function-name (basic-combination-fun node)) - (%nlx-entry - (let ((nlx-info (continuation-value - (first (basic-combination-args node))))) - (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - ((:catch :unwind-protect) - (consume :nlx-entry)) - ;; If for a lexical exit, we will see a breakup - ;; later, so don't consume :NLX-ENTRY now. - (:tagbody) - (:block - (let ((cont (nlx-info-continuation nlx-info))) - (when (interesting cont) - (push cont stack)))))) - (setf nlx-entry-p t)) - (%lexical-exit-breakup - (unless (byte-nlx-info-duplicate - (nlx-info-info - (continuation-value - (first (basic-combination-args node))))) - (consume :nlx-entry))) - ((%catch-breakup %unwind-protect-breakup) - (consume :nlx-entry)))) - (cif - (consume (if-test node))) - (creturn - (consume (return-result node))) - (entry - (let* ((cup (entry-cleanup node)) - (nlx-info (cleanup-nlx-info cup))) - (when nlx-info - (push :nlx-entry stack) - (push (list nlx-info stack (reverse consumes)) - nlx-entries)))) - (exit - (when (exit-value node) - (consume (exit-value node))))) - (when (and (not (exit-p node)) (interesting cont)) - (push cont stack))) - - (setf (block-info block) - (make-byte-block-info - block - :produces stack - :produces-sset (let ((res (make-sset))) - (dolist (product stack) - (adjoin-cont product res)) - res) - :consumes (reverse consumes) - :total-consumes total-consumes - :nlx-entries nlx-entries - :nlx-entry-p nlx-entry-p)))) - - (values)) - -(defun walk-successors (block stack) - (let ((tail (component-tail (block-component block)))) - (dolist (succ (block-succ block)) - (unless (or (eq succ tail) - (not (block-interesting succ)) - (byte-block-info-nlx-entry-p (block-info succ))) - (walk-block succ block stack))))) - -;;; Take a stack and a consumes list, and remove the appropriate -;;; stuff. When we consume a :NLX-ENTRY, we just remove the top -;;; marker, and leave any values on top intact. This represents the -;;; desired effect of %CATCH-BREAKUP, etc., which don't affect any -;;; values on the stack. -(defun consume-stuff (stack stuff) - (let ((new-stack stack)) - (dolist (cont stuff) - (cond ((eq cont :nlx-entry) - (aver (find :nlx-entry new-stack)) - (setq new-stack (remove :nlx-entry new-stack :count 1))) - (t - (aver (eq (car new-stack) cont)) - (pop new-stack)))) - new-stack)) - -;;; NLX-INFOS is the list of NLX-INFO structures for this ENTRY note. -;;; CONSUME and PRODUCE are the values from outside this block that -;;; were consumed and produced by this block before the ENTRY node. -;;; STACK is the globally simulated stack at the start of this block. -(defun walk-nlx-entry (nlx-infos stack produce consume) - (let ((stack (consume-stuff stack consume))) - (dolist (nlx-info nlx-infos) - (walk-block (nlx-info-target nlx-info) nil (append produce stack)))) - (values)) - -;;; Simulate the stack across block boundaries, discarding any values -;;; that are dead. A :NLX-ENTRY marker prevents values live at a NLX -;;; entry point from being discarded prematurely. -(defun walk-block (block pred stack) - ;; Pop everything off of stack that isn't live. - (let* ((info (block-info block)) - (live (byte-block-info-total-consumes info))) - (collect ((pops)) - (let ((fixed 0)) - (flet ((flush-fixed () - (unless (zerop fixed) - (pops `(%byte-pop-stack ,fixed)) - (setf fixed 0)))) - (loop - (unless stack - (return)) - (let ((cont (car stack))) - (when (or (eq cont :nlx-entry) - (sset-member (continuation-info cont) live)) - (return)) - (pop stack) - (let ((results - (byte-continuation-info-results - (continuation-info cont)))) - (case results - (:unknown - (flush-fixed) - (pops `(%byte-pop-stack 0))) - (:fdefinition - (incf fixed)) - (t - (incf fixed results)))))) - (flush-fixed))) - (when (pops) - (aver pred) - (let ((cleanup-block - (insert-cleanup-code pred block - (continuation-next (block-start block)) - `(progn ,@(pops))))) - (annotate-block cleanup-block)))) - - (cond ((eq (byte-block-info-start-stack info) :unknown) - ;; Record what the stack looked like at the start of this block. - (setf (byte-block-info-start-stack info) stack) - ;; Process any nlx entries that build off of our stack. - (dolist (stuff (byte-block-info-nlx-entries info)) - (walk-nlx-entry (first stuff) stack (second stuff) (third stuff))) - ;; Remove whatever we consume. - (setq stack (consume-stuff stack (byte-block-info-consumes info))) - ;; Add whatever we produce. - (setf stack (append (byte-block-info-produces info) stack)) - (setf (byte-block-info-end-stack info) stack) - ;; Pass that on to all our successors. - (walk-successors block stack)) - (t - ;; We have already processed the successors of this block. Just - ;; make sure we thing the stack is the same now as before. - (aver (equal (byte-block-info-start-stack info) stack))))) - (values)) - -;;; Do lifetime flow analysis on values pushed on the stack, then call -;;; do the stack simulation walk to discard dead values. In addition -;;; to considering the obvious inputs from a block's successors, we -;;; must also consider %NLX-ENTRY targets to be successors in order to -;;; ensure that any values only used in the NLX entry stay alive until -;;; we reach the mess-up node. After then, we can keep the values from -;;; being discarded by placing a marker on the simulated stack. -(defun byte-stack-analyze (component) - (declare (notinline find)) ; to avoid bug 117 bogowarnings - (let ((head nil)) - (let ((*byte-continuation-counter* 0)) - (do-blocks (block component) - (when (block-interesting block) - (compute-produces-and-consumes block) - (push block head) - (setf (byte-block-info-already-queued (block-info block)) t)))) - (let ((tail (last head))) - (labels ((maybe-enqueue (block) - (when (block-interesting block) - (let ((info (block-info block))) - (unless (byte-block-info-already-queued info) - (setf (byte-block-info-already-queued info) t) - (let ((new (list block))) - (if head - (setf (cdr tail) new) - (setf head new)) - (setf tail new)))))) - (maybe-enqueue-predecessors (block) - (when (byte-block-info-nlx-entry-p (block-info block)) - (maybe-enqueue - (node-block - (cleanup-mess-up - (nlx-info-cleanup - (find block - (environment-nlx-info (block-environment block)) - :key #'nlx-info-target)))))) - - (dolist (pred (block-pred block)) - (unless (eq pred (component-head (block-component block))) - (maybe-enqueue pred))))) - (loop - (unless head - (return)) - (let* ((block (pop head)) - (info (block-info block)) - (total-consumes (byte-block-info-total-consumes info)) - (produces-sset (byte-block-info-produces-sset info)) - (did-anything nil)) - (setf (byte-block-info-already-queued info) nil) - (dolist (succ (block-succ block)) - (unless (eq succ (component-tail component)) - (let ((succ-info (block-info succ))) - (when (sset-union-of-difference - total-consumes - (byte-block-info-total-consumes succ-info) - produces-sset) - (setf did-anything t))))) - (dolist (nlx-list (byte-block-info-nlx-entries info)) - (dolist (nlx-info (first nlx-list)) - (when (sset-union-of-difference - total-consumes - (byte-block-info-total-consumes - (block-info - (nlx-info-target nlx-info))) - produces-sset) - (setf did-anything t)))) - (when did-anything - (maybe-enqueue-predecessors block))))))) - - (walk-successors (component-head component) nil) - (values)) - -;;;; Actually generate the byte code. - -(defvar *byte-component-info*) - -;;; FIXME: These might as well be generated with DEFENUM, right? -;;; It would also be nice to give them less ambiguous names, perhaps -;;; with a "BYTEOP-" prefix instead of "BYTE-". -(defconstant byte-push-local #b00000000) -(defconstant byte-push-arg #b00010000) -(defconstant byte-push-constant #b00100000) -(defconstant byte-push-system-constant #b00110000) -(defconstant byte-push-int #b01000000) -(defconstant byte-push-neg-int #b01010000) -(defconstant byte-pop-local #b01100000) -(defconstant byte-pop-n #b01110000) -(defconstant byte-call #b10000000) -(defconstant byte-tail-call #b10010000) -(defconstant byte-multiple-call #b10100000) -(defconstant byte-named #b00001000) -(defconstant byte-local-call #b10110000) -(defconstant byte-local-tail-call #b10111000) -(defconstant byte-local-multiple-call #b11000000) -(defconstant byte-return #b11001000) -(defconstant byte-branch-always #b11010000) -(defconstant byte-branch-if-true #b11010010) -(defconstant byte-branch-if-false #b11010100) -(defconstant byte-branch-if-eq #b11010110) -(defconstant byte-xop #b11011000) -(defconstant byte-inline-function #b11100000) - -(defun output-push-int (segment int) - (declare (type sb!assem:segment segment) - (type (integer #.(- (ash 1 24)) #.(1- (ash 1 24))))) - (if (minusp int) - (output-byte-with-operand segment byte-push-neg-int (- (1+ int))) - (output-byte-with-operand segment byte-push-int int))) - -(defun output-push-constant-leaf (segment constant) - (declare (type sb!assem:segment segment) - (type constant constant)) - (let ((info (constant-info constant))) - (if info - (output-byte-with-operand segment - (ecase (car info) - (:system-constant - byte-push-system-constant) - (:local-constant - byte-push-constant)) - (cdr info)) - (let ((const (constant-value constant))) - (if (and (integerp const) (< (- (ash 1 24)) const (ash 1 24))) - ;; It can be represented as an immediate. - (output-push-int segment const) - ;; We need to store it in the constants pool. - (let* ((posn - (unless (and (consp const) - (eq (car const) '%fdefinition-marker%)) - (gethash const *system-constant-codes*))) - (new-info (if posn - (cons :system-constant posn) - (cons :local-constant - (vector-push-extend - constant - (byte-component-info-constants - *byte-component-info*)))))) - (setf (constant-info constant) new-info) - (output-push-constant-leaf segment constant))))))) - -(defun output-push-constant (segment value) - (if (and (integerp value) - (< (- (ash 1 24)) value (ash 1 24))) - (output-push-int segment value) - (output-push-constant-leaf segment (find-constant value)))) - -;;; Return the offset of a load-time constant in the constant pool, -;;; adding it if absent. -(defun byte-load-time-constant-index (kind datum) - (let ((constants (byte-component-info-constants *byte-component-info*))) - (or (position-if #'(lambda (x) - (and (consp x) - (eq (car x) kind) - (typecase datum - (cons (equal (cdr x) datum)) - (ctype (type= (cdr x) datum)) - (t - (eq (cdr x) datum))))) - constants) - (vector-push-extend (cons kind datum) constants)))) - -(defun output-push-load-time-constant (segment kind datum) - (output-byte-with-operand segment byte-push-constant - (byte-load-time-constant-index kind datum)) - (values)) - -(defun output-do-inline-function (segment function) - ;; Note: we don't annotate this as a call site, because it is used - ;; for internal stuff. Functions that get inlined have code - ;; locations added byte generate-byte-code-for-full-call below. - (output-byte segment - (logior byte-inline-function - (inline-function-number-or-lose function)))) - -(defun output-do-xop (segment xop) - (let ((index (xop-index-or-lose xop))) - (cond ((< index 7) - (output-byte segment (logior byte-xop index))) - (t - (output-byte segment (logior byte-xop 7)) - (output-byte segment index))))) - -(defun closure-position (var env) - (or (position var (environment-closure env)) - (error "Can't find ~S" var))) - -(defun output-ref-lambda-var (segment var env - &optional (indirect-value-cells t)) - (declare (type sb!assem:segment segment) - (type lambda-var var) - (type environment env)) - (if (eq (lambda-environment (lambda-var-home var)) env) - (let ((info (leaf-info var))) - (output-byte-with-operand segment - (if (byte-lambda-var-info-argp info) - byte-push-arg - byte-push-local) - (byte-lambda-var-info-offset info))) - (output-byte-with-operand segment - byte-push-arg - (closure-position var env))) - (when (and indirect-value-cells (lambda-var-indirect var)) - (output-do-inline-function segment 'value-cell-ref))) - -(defun output-ref-nlx-info (segment info env) - (if (eq (node-environment (cleanup-mess-up (nlx-info-cleanup info))) env) - (output-byte-with-operand segment - byte-push-local - (byte-nlx-info-stack-slot - (nlx-info-info info))) - (output-byte-with-operand segment - byte-push-arg - (closure-position info env)))) - -(defun output-set-lambda-var (segment var env &optional make-value-cells) - (declare (type sb!assem:segment segment) - (type lambda-var var) - (type environment env)) - (let ((indirect (lambda-var-indirect var))) - (cond ((not (eq (lambda-environment (lambda-var-home var)) env)) - ;; This is not this guy's home environment. So we need to - ;; get it the value cell out of the closure, and fill it in. - (aver indirect) - (aver (not make-value-cells)) - (output-byte-with-operand segment byte-push-arg - (closure-position var env)) - (output-do-inline-function segment 'value-cell-setf)) - (t - (let* ((pushp (and indirect (not make-value-cells))) - (byte-code (if pushp byte-push-local byte-pop-local)) - (info (leaf-info var))) - (aver (not (byte-lambda-var-info-argp info))) - (when (and indirect make-value-cells) - ;; Replace the stack top with a value cell holding the - ;; stack top. - (output-do-inline-function segment 'make-value-cell)) - (output-byte-with-operand segment byte-code - (byte-lambda-var-info-offset info)) - (when pushp - (output-do-inline-function segment 'value-cell-setf))))))) - -;;; Output whatever noise is necessary to canonicalize the values on -;;; the top of the stack. DESIRED is the number we want, and SUPPLIED -;;; is the number we have. Either push NIL or pop-n to make them -;;; balanced. Note: either desired or supplied can be :unknown, in -;;; which case it means use the ``unknown-values'' convention (which -;;; is the stack values followed by the number of values). -(defun canonicalize-values (segment desired supplied) - (declare (type sb!assem:segment segment) - (type (or (member :unknown) index) desired supplied)) - (cond ((eq desired :unknown) - (unless (eq supplied :unknown) - (output-byte-with-operand segment byte-push-int supplied))) - ((eq supplied :unknown) - (unless (eq desired :unknown) - (output-push-int segment desired) - (output-do-xop segment 'default-unknown-values))) - ((< supplied desired) - (dotimes (i (- desired supplied)) - (output-push-constant segment nil))) - ((> supplied desired) - (output-byte-with-operand segment byte-pop-n (- supplied desired)))) - (values)) - -(defparameter *byte-type-weakenings* - (mapcar #'specifier-type - '(fixnum single-float double-float simple-vector simple-bit-vector - bit-vector))) - -;;; Emit byte code to check that the value on top of the stack is of -;;; the specified TYPE. NODE is used for policy information. We weaken -;;; or entirely omit the type check whether speed is more important -;;; than safety. -(defun byte-generate-type-check (segment type node) - (declare (type ctype type) (type node node)) - (unless (or (policy node (zerop safety)) - (csubtypep *universal-type* type)) - (let ((type (if (policy node (> speed safety)) - (dolist (super *byte-type-weakenings* type) - (when (csubtypep type super) (return super))) - type))) - (output-do-xop segment 'type-check) - (output-extended-operand - segment - (byte-load-time-constant-index :type-predicate type))))) - -;;; This function is used when we are generating code which delivers -;;; values to a continuation. If this continuation needs a type check, -;;; and has a single value, then we do a type check. We also -;;; CANONICALIZE-VALUES for the continuation's desired number of -;;; values (without the placeholders.) -;;; -;;; Somewhat unrelatedly, we also push placeholders for deleted -;;; arguments to local calls. Although we check first, the actual -;;; PUSH-N-UNDER is done afterward, since then the single value we -;;; want is stack top. -(defun checked-canonicalize-values (segment cont supplied) - (let ((info (continuation-info cont))) - (if info - (let ((desired (byte-continuation-info-results info)) - (placeholders (byte-continuation-info-placeholders info))) - (unless (zerop placeholders) - (aver (eql desired (1+ placeholders))) - (setq desired 1)) - - (flet ((do-check () - (byte-generate-type-check - segment - (single-value-type (continuation-asserted-type cont)) - (continuation-dest cont)))) - (cond - ((member (continuation-type-check cont) '(nil :deleted)) - (canonicalize-values segment desired supplied)) - ((eql supplied 1) - (do-check) - (canonicalize-values segment desired supplied)) - ((eql desired 1) - (canonicalize-values segment desired supplied) - (do-check)) - (t - (canonicalize-values segment desired supplied)))) - - (unless (zerop placeholders) - (output-do-xop segment 'push-n-under) - (output-extended-operand segment placeholders))) - - (canonicalize-values segment 0 supplied)))) - -;;; Emit prologue for non-LET functions. Assigned arguments must be -;;; copied into locals, and argument type checking may need to be done. -(defun generate-byte-code-for-bind (segment bind cont) - (declare (type sb!assem:segment segment) (type bind bind) - (ignore cont)) - (let ((lambda (bind-lambda bind)) - (env (node-environment bind))) - (ecase (lambda-kind lambda) - ((nil :external :top-level :escape :cleanup :optional) - (let* ((info (lambda-info lambda)) - (type-check (policy (lambda-bind lambda) (not (zerop safety)))) - (frame-size (byte-lambda-info-stack-size info))) - (cond ((< frame-size (* 255 2)) - (output-byte segment (ceiling frame-size 2))) - (t - (output-byte segment 255) - (output-byte segment (ldb (byte 8 16) frame-size)) - (output-byte segment (ldb (byte 8 8) frame-size)) - (output-byte segment (ldb (byte 8 0) frame-size)))) - - (do ((argnum (1- (+ (length (lambda-vars lambda)) - (length (environment-closure - (lambda-environment lambda))))) - (1- argnum)) - (vars (lambda-vars lambda) (cdr vars)) - (pops 0)) - ((null vars) - (unless (zerop pops) - (output-byte-with-operand segment byte-pop-n pops))) - (declare (fixnum argnum pops)) - (let* ((var (car vars)) - (info (lambda-var-info var)) - (type (leaf-type var))) - (cond ((not info)) - ((byte-lambda-var-info-argp info) - (when (and type-check - (not (csubtypep *universal-type* type))) - (output-byte-with-operand segment byte-push-arg argnum) - (byte-generate-type-check segment type bind) - (incf pops))) - (t - (output-byte-with-operand segment byte-push-arg argnum) - (when type-check - (byte-generate-type-check segment type bind)) - (output-set-lambda-var segment var env t))))))) - - ;; Everything has been taken care of in the combination node. - ((:let :mv-let :assignment)))) - (values)) - -;;; This hashtable translates from n-ary function names to the -;;; two-arg-specific versions which we call to avoid &REST-arg consing. -(defvar *two-arg-functions* (make-hash-table :test 'eq)) - -(dolist (fun '((sb!kernel:two-arg-ior logior) - (sb!kernel:two-arg-* *) - (sb!kernel:two-arg-+ +) - (sb!kernel:two-arg-/ /) - (sb!kernel:two-arg-- -) - (sb!kernel:two-arg-> >) - (sb!kernel:two-arg-< <) - (sb!kernel:two-arg-= =) - (sb!kernel:two-arg-lcm lcm) - (sb!kernel:two-arg-and logand) - (sb!kernel:two-arg-gcd gcd) - (sb!kernel:two-arg-xor logxor) - - (two-arg-char= char=) - (two-arg-char< char<) - (two-arg-char> char>) - (two-arg-char-equal char-equal) - (two-arg-char-lessp char-lessp) - (two-arg-char-greaterp char-greaterp) - (two-arg-string= string=) - (two-arg-string< string<) - (two-arg-string> string>))) - - (setf (gethash (second fun) *two-arg-functions*) (first fun))) - -;;; If a system constant, push that, otherwise use a load-time constant. -(defun output-push-fdefinition (segment name) - (let ((offset (gethash `(%fdefinition-marker% . ,name) - *system-constant-codes*))) - (if offset - (output-byte-with-operand segment byte-push-system-constant - offset) - (output-push-load-time-constant segment :fdefinition name)))) - -(defun generate-byte-code-for-ref (segment ref cont) - (declare (type sb!assem:segment segment) (type ref ref) - (type continuation cont)) - (let ((info (continuation-info cont))) - ;; If there is no info, then nobody wants the result. - (when info - (let ((values (byte-continuation-info-results info)) - (leaf (ref-leaf ref))) - (cond - ((eq values :fdefinition) - (aver (and (global-var-p leaf) - (eq (global-var-kind leaf) - :global-function))) - (let* ((name (global-var-name leaf)) - (found (gethash name *two-arg-functions*))) - (output-push-fdefinition - segment - (if (and found - (= (length (basic-combination-args - (continuation-dest cont))) - 2)) - found - name)))) - ((eql values 0) - ;; really easy! - nil) - (t - (etypecase leaf - (constant - (cond ((legal-immediate-constant-p leaf) - (output-push-constant-leaf segment leaf)) - (t - (output-push-constant segment (leaf-name leaf)) - (output-do-inline-function segment 'symbol-value)))) - (clambda - (let* ((referred-env (lambda-environment leaf)) - (closure (environment-closure referred-env))) - (if (null closure) - (output-push-load-time-constant segment :entry leaf) - (let ((my-env (node-environment ref))) - (output-push-load-time-constant segment :entry leaf) - (dolist (thing closure) - (etypecase thing - (lambda-var - (output-ref-lambda-var segment thing my-env nil)) - (nlx-info - (output-ref-nlx-info segment thing my-env)))) - (output-push-int segment (length closure)) - (output-do-xop segment 'make-closure))))) - (functional - (output-push-load-time-constant segment :entry leaf)) - (lambda-var - (output-ref-lambda-var segment leaf (node-environment ref))) - (global-var - (ecase (global-var-kind leaf) - ((:special :global :constant) - (output-push-constant segment (global-var-name leaf)) - (output-do-inline-function segment 'symbol-value)) - (:global-function - (output-push-fdefinition segment (global-var-name leaf)) - (output-do-xop segment 'fdefn-function-or-lose))))) - (checked-canonicalize-values segment cont 1)))))) - (values)) - -(defun generate-byte-code-for-set (segment set cont) - (declare (type sb!assem:segment segment) (type cset set) - (type continuation cont)) - (let* ((leaf (set-var set)) - (info (continuation-info cont)) - (values (if info - (byte-continuation-info-results info) - 0))) - (unless (eql values 0) - ;; Someone wants the value, so copy it. - (output-do-xop segment 'dup)) - (etypecase leaf - (global-var - (ecase (global-var-kind leaf) - ((:special :global) - (output-push-constant segment (global-var-name leaf)) - (output-do-inline-function segment 'setf-symbol-value)))) - (lambda-var - ;; Note: It's important to test for whether there are any - ;; references to the variable before we actually try to set it. - ;; (Setting a lexical variable with no refs caused bugs ca. CMU - ;; CL 18c, because the compiler deletes such variables.) - (cond ((leaf-refs leaf) - (output-set-lambda-var segment leaf (node-environment set))) - ;; If no one wants the value, then pop it, else leave it - ;; for them. - ((eql values 0) - (output-byte-with-operand segment byte-pop-n 1))))) - (unless (eql values 0) - (checked-canonicalize-values segment cont 1))) - (values)) - -(defun generate-byte-code-for-local-call (segment call cont num-args) - (let* ((lambda (combination-lambda call)) - (vars (lambda-vars lambda)) - (env (lambda-environment lambda))) - (ecase (functional-kind lambda) - ((:let :assignment) - (dolist (var (reverse vars)) - (when (lambda-var-refs var) - (output-set-lambda-var segment var env t)))) - (:mv-let - (let ((do-check (member (continuation-type-check - (first (basic-combination-args call))) - '(t :error)))) - (dolist (var (reverse vars)) - (when do-check - (byte-generate-type-check segment (leaf-type var) call)) - (output-set-lambda-var segment var env t)))) - ((nil :optional :cleanup) - ;; We got us a local call. - (aver (not (eq num-args :unknown))) - ;; Push any trailing placeholder args... - (dolist (x (reverse (basic-combination-args call))) - (when x (return)) - (output-push-int segment 0)) - ;; Then push closure vars. - (let ((closure (environment-closure env))) - (when closure - (let ((my-env (node-environment call))) - (dolist (thing (reverse closure)) - (etypecase thing - (lambda-var - (output-ref-lambda-var segment thing my-env nil)) - (nlx-info - (output-ref-nlx-info segment thing my-env))))) - (incf num-args (length closure)))) - (let ((results - (let ((info (continuation-info cont))) - (if info - (byte-continuation-info-results info) - 0)))) - ;; Emit the op for whatever flavor of call we are using. - (let ((operand - (cond ((> num-args 6) - (output-push-int segment num-args) - 7) - (t - num-args)))) - (multiple-value-bind (opcode ret-vals) - (cond ((node-tail-p call) - (values byte-local-tail-call 0)) - ((member results '(0 1)) - (values byte-local-call 1)) - (t - (values byte-local-multiple-call :unknown))) - ;; ### :call-site - (output-byte segment (logior opcode operand)) - ;; Emit a reference to the label. - (output-reference segment - (byte-lambda-info-label (lambda-info lambda))) - ;; ### :unknown-return - ;; Fix up the results. - (unless (node-tail-p call) - (checked-canonicalize-values segment cont ret-vals)))))))) - (values)) - -(defun generate-byte-code-for-full-call (segment call cont num-args) - (let ((info (basic-combination-info call)) - (results - (let ((info (continuation-info cont))) - (if info - (byte-continuation-info-results info) - 0)))) - (cond - (info - ;; It's an inline function. - (aver (not (node-tail-p call))) - (let* ((type (inline-function-info-type info)) - (desired-args (function-type-nargs type)) - (supplied-results - (nth-value 1 - (values-types (function-type-returns type)))) - (leaf (ref-leaf (continuation-use (basic-combination-fun call))))) - (cond ((slot-accessor-p leaf) - (aver (= num-args (1- desired-args))) - (output-push-int segment (dsd-index (slot-accessor-slot leaf)))) - (t - (canonicalize-values segment desired-args num-args))) - ;; ### :call-site - (output-byte segment (logior byte-inline-function - (inline-function-info-number info))) - ;; ### :known-return - (checked-canonicalize-values segment cont supplied-results))) - (t - (let ((operand - (cond ((eq num-args :unknown) - 7) - ((> num-args 6) - (output-push-int segment num-args) - 7) - (t - num-args)))) - (when (eq (byte-continuation-info-results - (continuation-info - (basic-combination-fun call))) - :fdefinition) - (setf operand (logior operand byte-named))) - ;; ### :call-site - (cond - ((node-tail-p call) - (output-byte segment (logior byte-tail-call operand))) - (t - (multiple-value-bind (opcode ret-vals) - (case results - (:unknown (values byte-multiple-call :unknown)) - ((0 1) (values byte-call 1)) - (t (values byte-multiple-call :unknown))) - (output-byte segment (logior opcode operand)) - ;; ### :unknown-return - (checked-canonicalize-values segment cont ret-vals))))))))) - -(defun generate-byte-code-for-known-call (segment call cont num-args) - (block nil - (catch 'give-up-ir1-transform - (funcall (function-info-byte-compile (basic-combination-kind call)) call - (let ((info (continuation-info cont))) - (if info - (byte-continuation-info-results info) - 0)) - num-args segment) - (return)) - (aver (member (byte-continuation-info-results - (continuation-info - (basic-combination-fun call))) - '(1 :fdefinition))) - (generate-byte-code-for-full-call segment call cont num-args)) - (values)) - -(defun generate-byte-code-for-generic-combination (segment call cont) - (declare (type sb!assem:segment segment) (type basic-combination call) - (type continuation cont)) - (labels ((examine (args num-fixed) - (cond - ((null args) - ;; None of the arugments supply :UNKNOWN values, so - ;; we know exactly how many there are. - num-fixed) - (t - (let* ((vals - (byte-continuation-info-results - (continuation-info (car args))))) - (cond - ((eq vals :unknown) - (unless (null (cdr args)) - ;; There are (LENGTH ARGS) :UNKNOWN value blocks on - ;; the top of the stack. We need to combine them. - (output-push-int segment (length args)) - (output-do-xop segment 'merge-unknown-values)) - (unless (zerop num-fixed) - ;; There are num-fixed fixed args above the unknown - ;; values block that want in on the action also. - ;; So add num-fixed to the count. - (output-push-int segment num-fixed) - (output-do-inline-function segment '+)) - :unknown) - (t - (examine (cdr args) (+ num-fixed vals))))))))) - (let* ((args (basic-combination-args call)) - (kind (basic-combination-kind call)) - (num-args (if (and (eq kind :local) - (combination-p call)) - (length args) - (examine args 0)))) - (case kind - (:local - (generate-byte-code-for-local-call segment call cont num-args)) - (:full - (generate-byte-code-for-full-call segment call cont num-args)) - (t - (generate-byte-code-for-known-call segment call cont num-args)))))) - -(defun generate-byte-code-for-basic-combination (segment call cont) - (cond ((and (mv-combination-p call) - (eq (continuation-function-name (basic-combination-fun call)) - '%throw)) - ;; ### :internal-error - (output-do-xop segment 'throw)) - (t - (generate-byte-code-for-generic-combination segment call cont)))) - -(defun generate-byte-code-for-if (segment if cont) - (declare (type sb!assem:segment segment) (type cif if) - (ignore cont)) - (let* ((next-info (byte-block-info-next (block-info (node-block if)))) - (consequent-info (block-info (if-consequent if))) - (alternate-info (block-info (if-alternative if)))) - (cond ((eq (byte-continuation-info-results - (continuation-info (if-test if))) - :eq-test) - (output-branch segment - byte-branch-if-eq - (byte-block-info-label consequent-info)) - (unless (eq next-info alternate-info) - (output-branch segment - byte-branch-always - (byte-block-info-label alternate-info)))) - ((eq next-info consequent-info) - (output-branch segment - byte-branch-if-false - (byte-block-info-label alternate-info))) - (t - (output-branch segment - byte-branch-if-true - (byte-block-info-label consequent-info)) - (unless (eq next-info alternate-info) - (output-branch segment - byte-branch-always - (byte-block-info-label alternate-info))))))) - -(defun generate-byte-code-for-return (segment return cont) - (declare (type sb!assem:segment segment) (type creturn return) - (ignore cont)) - (let* ((result (return-result return)) - (info (continuation-info result)) - (results (byte-continuation-info-results info))) - (cond ((eq results :unknown) - (setf results 7)) - ((> results 6) - (output-byte-with-operand segment byte-push-int results) - (setf results 7))) - (output-byte segment (logior byte-return results))) - (values)) - -(defun generate-byte-code-for-entry (segment entry cont) - (declare (type sb!assem:segment segment) (type entry entry) - (ignore cont)) - (dolist (exit (entry-exits entry)) - (let ((nlx-info (find-nlx-info entry (node-cont exit)))) - (when nlx-info - (let ((kind (cleanup-kind (nlx-info-cleanup nlx-info)))) - (when (member kind '(:block :tagbody)) - ;; Generate a unique tag. - (output-push-constant - segment - (format nil - "tag for ~A" - (component-name *component-being-compiled*))) - (output-push-constant segment nil) - (output-do-inline-function segment 'cons) - ;; Save it so people can close over it. - (output-do-xop segment 'dup) - (output-byte-with-operand segment - byte-pop-local - (byte-nlx-info-stack-slot - (nlx-info-info nlx-info))) - ;; Now do the actual XOP. - (ecase kind - (:block - (output-do-xop segment 'catch) - (output-reference segment - (byte-nlx-info-label - (nlx-info-info nlx-info)))) - (:tagbody - (output-do-xop segment 'tagbody))) - (return)))))) - (values)) - -(defun generate-byte-code-for-exit (segment exit cont) - (declare (ignore cont)) - (let ((nlx-info (find-nlx-info (exit-entry exit) (node-cont exit)))) - (output-byte-with-operand segment - byte-push-arg - (closure-position nlx-info - (node-environment exit))) - (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - (:block - ;; ### :internal-error - (output-do-xop segment 'return-from)) - (:tagbody - ;; ### :internal-error - (output-do-xop segment 'go) - (output-reference segment - (byte-nlx-info-label (nlx-info-info nlx-info))))))) - -(defun generate-byte-code (segment component) - (let ((*byte-component-info* (component-info component))) - (do* ((info (byte-block-info-next (block-info (component-head component))) - next) - (block (byte-block-info-block info) (byte-block-info-block info)) - (next (byte-block-info-next info) (byte-block-info-next info))) - ((eq block (component-tail component))) - (when (block-interesting block) - (output-label segment (byte-block-info-label info)) - (do-nodes (node cont block) - (etypecase node - (bind (generate-byte-code-for-bind segment node cont)) - (ref (generate-byte-code-for-ref segment node cont)) - (cset (generate-byte-code-for-set segment node cont)) - (basic-combination - (generate-byte-code-for-basic-combination - segment node cont)) - (cif (generate-byte-code-for-if segment node cont)) - (creturn (generate-byte-code-for-return segment node cont)) - (entry (generate-byte-code-for-entry segment node cont)) - (exit - (when (exit-entry node) - (generate-byte-code-for-exit segment node cont))))) - (let* ((succ (block-succ block)) - (first-succ (car succ)) - (last (block-last block))) - (unless (or (cdr succ) - (eq (byte-block-info-block next) first-succ) - (eq (component-tail component) first-succ) - (and (basic-combination-p last) - (node-tail-p last) - ;; Tail local calls that have been - ;; converted to an assignment need the - ;; branch. - (not (and (eq (basic-combination-kind last) :local) - (member (functional-kind - (combination-lambda last)) - '(:let :assignment)))))) - (output-branch segment - byte-branch-always - (byte-block-info-label - (block-info first-succ)))))))) - (values)) - -;;;; special purpose annotate/compile optimizers - -(defoptimizer (eq byte-annotate) ((this that) node) - (declare (ignore this that)) - (when (if-p (continuation-dest (node-cont node))) - (annotate-known-call node) - t)) - -(defoptimizer (eq byte-compile) ((this that) call results num-args segment) - (progn segment) ; ignorable. - ;; We don't have to do anything, because everything is handled by - ;; the IF byte-generator. - (aver (eq results :eq-test)) - (aver (eql num-args 2)) - (values)) - -(defoptimizer (values byte-compile) - ((&rest values) node results num-args segment) - (canonicalize-values segment results num-args)) - -(defknown %byte-pop-stack (index) (values)) - -(defoptimizer (%byte-pop-stack byte-annotate) ((count) node) - (aver (constant-continuation-p count)) - (annotate-continuation count 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%byte-pop-stack byte-compile) - ((count) node results num-args segment) - (aver (and (zerop num-args) (zerop results))) - (output-byte-with-operand segment byte-pop-n (continuation-value count))) - -(defoptimizer (%special-bind byte-annotate) ((var value) node) - (annotate-continuation var 0) - (annotate-continuation value 1) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%special-bind byte-compile) - ((var value) node results num-args segment) - (aver (and (eql num-args 1) (zerop results))) - (output-push-constant segment (leaf-name (continuation-value var))) - (output-do-inline-function segment '%byte-special-bind)) - -(defoptimizer (%special-unbind byte-annotate) ((var) node) - (annotate-continuation var 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%special-unbind byte-compile) - ((var) node results num-args segment) - (aver (and (zerop num-args) (zerop results))) - (output-do-inline-function segment '%byte-special-unbind)) - -(defoptimizer (%catch byte-annotate) ((nlx-info tag) node) - (annotate-continuation nlx-info 0) - (annotate-continuation tag 1) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%catch byte-compile) - ((nlx-info tag) node results num-args segment) - (progn node) ; ignore - (aver (and (= num-args 1) (zerop results))) - (output-do-xop segment 'catch) - (let ((info (nlx-info-info (continuation-value nlx-info)))) - (output-reference segment (byte-nlx-info-label info)))) - -(defoptimizer (%cleanup-point byte-compile) (() node results num-args segment) - (progn node segment) ; ignore - (aver (and (zerop num-args) (zerop results)))) - -(defoptimizer (%catch-breakup byte-compile) (() node results num-args segment) - (progn node) ; ignore - (aver (and (zerop num-args) (zerop results))) - (output-do-xop segment 'breakup)) - -(defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node) - (annotate-continuation nlx-info 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%lexical-exit-breakup byte-compile) - ((nlx-info) node results num-args segment) - (aver (and (zerop num-args) (zerop results))) - (let ((nlx-info (continuation-value nlx-info))) - (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - (:block - ;; We only want to do this for the fall-though case. - (not (eq (car (block-pred (node-block node))) - (nlx-info-target nlx-info)))) - (:tagbody - ;; Only want to do it once per tagbody. - (not (byte-nlx-info-duplicate (nlx-info-info nlx-info))))) - (output-do-xop segment 'breakup)))) - -(defoptimizer (%nlx-entry byte-annotate) ((nlx-info) node) - (annotate-continuation nlx-info 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%nlx-entry byte-compile) - ((nlx-info) node results num-args segment) - (progn node results) ; ignore - (aver (eql num-args 0)) - (let* ((info (continuation-value nlx-info)) - (byte-info (nlx-info-info info))) - (output-label segment (byte-nlx-info-label byte-info)) - ;; ### :non-local-entry - (ecase (cleanup-kind (nlx-info-cleanup info)) - ((:catch :block) - (checked-canonicalize-values segment - (nlx-info-continuation info) - :unknown)) - ((:tagbody :unwind-protect))))) - -(defoptimizer (%unwind-protect byte-annotate) - ((nlx-info cleanup-fun) node) - (annotate-continuation nlx-info 0) - (annotate-continuation cleanup-fun 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%unwind-protect byte-compile) - ((nlx-info cleanup-fun) node results num-args segment) - (aver (and (zerop num-args) (zerop results))) - (output-do-xop segment 'unwind-protect) - (output-reference segment - (byte-nlx-info-label - (nlx-info-info - (continuation-value nlx-info))))) - -(defoptimizer (%unwind-protect-breakup byte-compile) - (() node results num-args segment) - (progn node) ; ignore - (aver (and (zerop num-args) (zerop results))) - (output-do-xop segment 'breakup)) - -(defoptimizer (%continue-unwind byte-annotate) ((a b c) node) - (annotate-continuation a 0) - (annotate-continuation b 0) - (annotate-continuation c 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%continue-unwind byte-compile) - ((a b c) node results num-args segment) - (progn node) ; ignore - (aver (member results '(0 nil))) - (aver (eql num-args 0)) - (output-do-xop segment 'breakup)) - -(defoptimizer (%load-time-value byte-annotate) ((handle) node) - (annotate-continuation handle 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%load-time-value byte-compile) - ((handle) node results num-args segment) - (progn node) ; ignore - (aver (zerop num-args)) - (output-push-load-time-constant segment :load-time-value - (continuation-value handle)) - (canonicalize-values segment results 1)) - -;;; Make a byte-function for LAMBDA. -(defun make-xep-for (lambda) - (flet ((entry-point-for (entry) - (let ((info (lambda-info entry))) - (aver (byte-lambda-info-interesting info)) - (sb!assem:label-position (byte-lambda-info-label info))))) - (let ((entry (lambda-entry-function lambda))) - (etypecase entry - (optional-dispatch - (let ((rest-arg-p nil) - (num-more 0)) - (declare (type index num-more)) - (collect ((keywords)) - (dolist (var (nthcdr (optional-dispatch-max-args entry) - (optional-dispatch-arglist entry))) - (let ((arg-info (lambda-var-arg-info var))) - (aver arg-info) - (ecase (arg-info-kind arg-info) - (:rest - (aver (not rest-arg-p)) - (incf num-more) - (setf rest-arg-p t)) - (:keyword - ;; FIXME: Since ANSI specifies that &KEY arguments - ;; needn't actually be keywords, :KEY would be a - ;; better label for this behavior than :KEYWORD is, - ;; and (KEY-ARGS) would be a better name for the - ;; accumulator than (KEYWORDS) is. - (let ((s-p (arg-info-supplied-p arg-info)) - (default (arg-info-default arg-info))) - (incf num-more (if s-p 2 1)) - (keywords (list (arg-info-key arg-info) - (if (constantp default) - (eval default) - nil) - (if s-p t nil)))))))) - (make-hairy-byte-function - :name (leaf-name entry) - :min-args (optional-dispatch-min-args entry) - :max-args (optional-dispatch-max-args entry) - :entry-points - (mapcar #'entry-point-for (optional-dispatch-entry-points entry)) - :more-args-entry-point - (entry-point-for (optional-dispatch-main-entry entry)) - :num-more-args num-more - :rest-arg-p rest-arg-p - :keywords-p - (if (optional-dispatch-keyp entry) - (if (optional-dispatch-allowp entry) - :allow-others t)) - :keywords (keywords))))) - (clambda - (let ((args (length (lambda-vars entry)))) - (make-simple-byte-function - :name (leaf-name entry) - :num-args args - :entry-point (entry-point-for entry)))))))) - -(defun generate-xeps (component) - (let ((xeps nil)) - (dolist (lambda (component-lambdas component)) - (when (or (member (lambda-kind lambda) '(:external :top-level)) - (lambda-has-external-references-p lambda)) - (push (cons lambda (make-xep-for lambda)) xeps))) - xeps)) - -;;;; noise to actually do the compile - -(defun assign-locals (component) - ;; Process all of the LAMBDAs in COMPONENT, and assign stack frame - ;; locations for all the locals. - (dolist (lambda (component-lambdas component)) - ;; We don't generate any code for pure :EXTERNAL lambdas, so we - ;; don't need to allocate stack space for them. Also, we don't use - ;; the ``more'' entry point, so we don't need code for it. - (cond - ((or (and (eq (lambda-kind lambda) :external) - (not (lambda-has-external-references-p lambda))) - (and (eq (lambda-kind lambda) :optional) - (eq (optional-dispatch-more-entry - (lambda-optional-dispatch lambda)) - lambda))) - (setf (lambda-info lambda) - (make-byte-lambda-info :interesting nil))) - (t - (let ((num-locals 0)) - (let* ((vars (lambda-vars lambda)) - (arg-num (+ (length vars) - (length (environment-closure - (lambda-environment lambda)))))) - (dolist (var vars) - (decf arg-num) - (cond ((or (lambda-var-sets var) (lambda-var-indirect var)) - (setf (leaf-info var) - (make-byte-lambda-var-info :offset num-locals)) - (incf num-locals)) - ((leaf-refs var) - (setf (leaf-info var) - (make-byte-lambda-var-info :argp t - :offset arg-num)))))) - (dolist (let (lambda-lets lambda)) - (dolist (var (lambda-vars let)) - (setf (leaf-info var) - (make-byte-lambda-var-info :offset num-locals)) - (incf num-locals))) - (let ((entry-nodes-already-done nil)) - (dolist (nlx-info (environment-nlx-info (lambda-environment lambda))) - (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - (:block - (setf (nlx-info-info nlx-info) - (make-byte-nlx-info :stack-slot num-locals)) - (incf num-locals)) - (:tagbody - (let* ((entry (cleanup-mess-up (nlx-info-cleanup nlx-info))) - (cruft (assoc entry entry-nodes-already-done))) - (cond (cruft - (setf (nlx-info-info nlx-info) - (make-byte-nlx-info :stack-slot (cdr cruft) - :duplicate t))) - (t - (push (cons entry num-locals) entry-nodes-already-done) - (setf (nlx-info-info nlx-info) - (make-byte-nlx-info :stack-slot num-locals)) - (incf num-locals))))) - ((:catch :unwind-protect) - (setf (nlx-info-info nlx-info) (make-byte-nlx-info)))))) - (setf (lambda-info lambda) - (make-byte-lambda-info :stack-size num-locals)))))) - - (values)) - -(defun byte-compile-component (component) - (/show "entering BYTE-COMPILE-COMPONENT") - (setf (component-info component) (make-byte-component-info)) - (maybe-mumble "ByteAnn ") - - ;; Assign offsets for all the locals, and figure out which args can - ;; stay in the argument area and which need to be moved into locals. - (assign-locals component) - - ;; Annotate every continuation with information about how we want - ;; the values. - (annotate-ir1 component) - - ;; Determine what stack values are dead, and emit cleanup code to - ;; pop them. - (byte-stack-analyze component) - - ;; Make sure any newly added blocks have a block-number. - (dfo-as-needed component) - - ;; Assign an ordering of the blocks. - (control-analyze component #'make-byte-block-info) - - ;; Find the start labels for the lambdas. - (dolist (lambda (component-lambdas component)) - (let ((info (lambda-info lambda))) - (when (byte-lambda-info-interesting info) - (setf (byte-lambda-info-label info) - (byte-block-info-label - (block-info (node-block (lambda-bind lambda)))))))) - - ;; Delete any blocks that we are not going to emit from the emit order. - (do-blocks (block component) - (unless (block-interesting block) - (let* ((info (block-info block)) - (prev (byte-block-info-prev info)) - (next (byte-block-info-next info))) - (setf (byte-block-info-next prev) next) - (setf (byte-block-info-prev next) prev)))) - - (maybe-mumble "ByteGen ") - (let ((segment nil)) - (unwind-protect - (progn - (setf segment (sb!assem:make-segment :name "Byte Output")) - (generate-byte-code segment component) - (let ((code-length (sb!assem:finalize-segment segment)) - (xeps (generate-xeps component)) - (constants (byte-component-info-constants - (component-info component)))) - (when *compiler-trace-output* - (describe-component component *compiler-trace-output*) - (describe-byte-component component xeps segment - *compiler-trace-output*)) - (etypecase *compile-object* - (fasl-output - (maybe-mumble "FASL") - (fasl-dump-byte-component segment code-length constants xeps - *compile-object*)) - (core-object - (maybe-mumble "Core") - (make-core-byte-component segment code-length constants xeps - *compile-object*)) - (null)))))) - (/show "leaving BYTE-COMPILE-COMPONENT") - (values)) - -;;;; extra stuff for debugging - -#!+sb-show -(defun dump-stack-info (component) - (do-blocks (block component) - (when (block-interesting block) - (print-nodes block) - (let ((info (block-info block))) - (cond - (info - (format t - "start-stack ~S~%consume ~S~%produce ~S~%end-stack ~S~%~ - total-consume ~S~%~@[nlx-entries ~S~%~]~@[nlx-entry-p ~S~%~]" - (byte-block-info-start-stack info) - (byte-block-info-consumes info) - (byte-block-info-produces info) - (byte-block-info-end-stack info) - (byte-block-info-total-consumes info) - (byte-block-info-nlx-entries info) - (byte-block-info-nlx-entry-p info))) - (t - (format t "no info~%"))))))) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 92f4f13..635960b 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -489,8 +489,7 @@ (mark-error-continuation cont) (unless (policy node (= inhibit-warnings 3)) (do-type-warning use)))))) - (when (and (eq type-check t) - (not *byte-compiling*)) + (when (eq type-check t) (cond ((probable-type-check-p cont) (conts cont)) (t diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 043013f..3848eb2 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -250,10 +250,8 @@ :created (file-info-write-date file-info) :compiled (source-info-start-time info) :source-root (file-info-source-root file-info) - :start-positions - (unless (eq *byte-compile* t) - (coerce-to-smallest-eltype - (file-info-positions file-info))))) + :start-positions (coerce-to-smallest-eltype + (file-info-positions file-info)))) (name (file-info-name file-info))) (etypecase name ((member :lisp) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 492d1cb..c565cae 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -903,7 +903,7 @@ (def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn) (def-frob *label-id* *id-labels* *label-ids* label-id id-label)) -;;; Print out a terse one-line description of a leaf. +;;; Print a terse one-line description of LEAF. (defun print-leaf (leaf &optional (stream *standard-output*)) (declare (type leaf leaf) (type stream stream)) (etypecase leaf @@ -919,10 +919,7 @@ (functional (aver (eq (functional-kind leaf) :top-level-xep)) (format stream "TL-XEP ~S" - (let ((info (leaf-info leaf))) - (etypecase info - (entry-info (entry-info-name info)) - (byte-lambda-info :byte-compiled-entry))))))) + (entry-info-name (leaf-info leaf)))))) ;;; Attempt to find a block given some thing that has to do with it. (declaim (ftype (function (t) cblock) block-or-lose)) diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index d821b6b..1eea045 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -480,9 +480,6 @@ (,format-var (format-or-lose ',format-name)) (args ,(gen-args-def-form field-defs format-var evalp)) (funcache *disassem-function-cache*)) - ;; FIXME: This should be SPEED 0 but can't be until we support - ;; byte compilation of components of the SBCL system. - ;;(declare (optimize (speed 0) (safety 0) (debug 0))) (multiple-value-bind (printer-fun printer-defun) (find-printer-fun ',uniquified-name ',format-name @@ -1047,8 +1044,6 @@ "-PRINTER")) (make-printer-defun printer-source funstate name))))) -;;;; Note that these things are compiled byte compiled to save space. - (defun make-printer-defun (source funstate function-name) (let ((printer-form (compile-printer-list source funstate)) (bindings (make-arg-temp-bindings funstate))) @@ -1056,10 +1051,7 @@ (declare (type dchunk chunk) (type instruction inst) (type stream stream) - (type disassem-state dstate) - ;; FIXME: This should be SPEED 0 but can't be until we support - ;; byte compilation of components of the SBCL system. - #+nil (optimize (speed 0) (safety 0) (debug 0))) + (type disassem-state dstate)) (macrolet ((local-format-arg (arg fmt) `(funcall (formatter ,fmt) stream ,arg))) (flet ((local-tab-to-arg-column () @@ -1432,11 +1424,7 @@ `(defun ,name (chunk labels dstate) (declare (type list labels) (type dchunk chunk) - (type disassem-state dstate) - ;; FIXME: This should be SPEED 0 but can't be - ;; until we support byte compilation of - ;; components of the SBCL system. - #+nil (optimize (speed 0) (safety 0) (debug 0))) + (type disassem-state dstate)) (flet ((local-filtered-value (offset) (declare (type filtered-value-index offset)) (aref (dstate-filtered-values dstate) offset)) @@ -1476,11 +1464,7 @@ )) `(defun ,name (chunk dstate) (declare (type dchunk chunk) - (type disassem-state dstate) - ;; FIXME: This should be SPEED 0 but can't be - ;; until we support byte compilation of - ;; components of the SBCL system. - #+nil (optimize (speed 0) (safety 0) (debug 0))) + (type disassem-state dstate)) (flet (((setf local-filtered-value) (value offset) (declare (type filtered-value-index offset)) (setf (aref (dstate-filtered-values dstate) offset) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 927ea0f..e81d381 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -251,7 +251,7 @@ ;;; the source code is given by the string WHERE. If BYTE-P is true, ;;; this file will contain no native code, and is thus largely ;;; implementation independent. -(defun open-fasl-output (name where &optional byte-p) +(defun open-fasl-output (name where) (declare (type pathname name)) (let* ((stream (open name :direction :output @@ -282,9 +282,7 @@ ;; Finish the header by outputting fasl file implementation and ;; version in machine-readable form. - (let ((implementation (if byte-p - (backend-byte-fasl-file-implementation) - +backend-fasl-file-implementation+))) + (let ((implementation +backend-fasl-file-implementation+)) (dump-unsigned-32 (length (symbol-name implementation)) res) (dotimes (i (length (symbol-name implementation))) (dump-byte (char-code (aref (symbol-name implementation) i)) res))) diff --git a/src/compiler/envanal.lisp b/src/compiler/envanal.lisp index 5592641..6ab14e9 100644 --- a/src/compiler/envanal.lisp +++ b/src/compiler/envanal.lisp @@ -49,8 +49,7 @@ (when (null (leaf-refs fun)) (let ((kind (functional-kind fun))) (unless (or (eq kind :top-level) - (functional-has-external-references-p fun) - (and *byte-compiling* (eq kind :optional))) + (functional-has-external-references-p fun)) (aver (member kind '(:optional :cleanup :escape))) (setf (functional-kind fun) nil) (delete-functional fun))))) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 9ad9f7e..e426747 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -154,8 +154,7 @@ (deftransform scale-float ((f ex) (single-float *) * :when :both) (if (and #!+x86 t #!-x86 nil (csubtypep (continuation-type ex) - (specifier-type '(signed-byte 32))) - (not (byte-compiling))) + (specifier-type '(signed-byte 32)))) '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float) '(scale-single-float f ex))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 986689d..a55a07a 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1170,8 +1170,7 @@ ;; extensions (:trace-file t) - (:block-compile t) - (:byte-compile (member t nil :maybe))) + (:block-compile t)) (values (or pathname null) boolean boolean)) (defknown disassemble (callable &key diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index d156696..6a7aae5 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2250,11 +2250,6 @@ (define-cold-fop (fop-sanctify-for-execution) (pop-stack)) -;;; FIXME: byte compiler to be removed completely -#| -(not-cold-fop fop-make-byte-compiled-function) -|# - ;;; Setting this variable shows what code looks like before any ;;; fixups (or function headers) are applied. #!+sb-show (defvar *show-pre-fixup-code-p* nil) diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index da4ac3c..b09a66f 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -105,67 +105,3 @@ (setf (code-header-ref code-obj index) (fdefinition-object (cdr const) t)))))))))) (values)) - -;;; FIXME: byte compiler to go away completely -#| -(defun make-core-byte-component (segment length constants xeps object) - (declare (type sb!assem:segment segment) - (type index length) - (type vector constants) - (type list xeps) - (type core-object object)) - (without-gcing - (let* ((num-constants (length constants)) - ;; KLUDGE: On the X86, using ALLOCATE-CODE-OBJECT is - ;; supposed to make the result non-relocatable, which is - ;; probably not what we want. Could this be made into - ;; ALLOCATE-DYNAMIC-CODE-OBJECT? Is there some other fix? - ;; Am I just confused? -- WHN 19990916 - (code-obj (%primitive allocate-code-object - (the index (1+ num-constants)) - length)) - (fill-ptr (code-instructions code-obj))) - (declare (type index length) - (type system-area-pointer fill-ptr)) - (sb!assem:on-segment-contents-vectorly - segment - (lambda (v) - (declare (type (simple-array sb!assem:assembly-unit 1) v)) - (copy-byte-vector-to-system-area v fill-ptr) - (setf fill-ptr (sap+ fill-ptr (length v))))) - - (setf (code-header-ref code-obj sb!vm:code-trace-table-offset-slot) - nil) - (dolist (noise xeps) - (let ((xep (cdr noise))) - (setf (byte-function-component xep) code-obj) - (initialize-byte-compiled-function xep) - (note-function (lambda-info (car noise)) xep object))) - - (dotimes (index num-constants) - (let ((const (aref constants index)) - (code-obj-index (+ index sb!vm:code-constants-offset))) - (etypecase const - (null) - (constant - (setf (code-header-ref code-obj code-obj-index) - (constant-value const))) - (list - (ecase (car const) - (:entry - (reference-core-function code-obj code-obj-index (cdr const) - object)) - (:fdefinition - (setf (code-header-ref code-obj code-obj-index) - (sb!impl::fdefinition-object (cdr const) t))) - (:type-predicate - (let ((*unparse-function-type-simplify* t)) - (setf (code-header-ref code-obj code-obj-index) - (load-type-predicate (type-specifier (cdr const)))))) - (:xep - (let ((xep (cdr (assoc (cdr const) xeps :test #'eq)))) - (aver xep) - (setf (code-header-ref code-obj code-obj-index) xep)))))))))) - - (values)) -|# \ No newline at end of file diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 7d9bebd..5bf475e 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -788,8 +788,7 @@ (declare (type combination call)) (let* ((ref (continuation-use (basic-combination-fun call))) (leaf (when (ref-p ref) (ref-leaf ref))) - (inlinep (if (and (defined-function-p leaf) - (not (byte-compiling))) + (inlinep (if (defined-function-p leaf) (defined-function-inlinep leaf) :no-chance))) (cond @@ -949,9 +948,7 @@ (policy node (> speed inhibit-warnings)))) (*compiler-error-context* node)) (cond ((not (member (transform-when transform) - (if *byte-compiling* - '(:byte :both) - '(:native :both)))) + '(:native :both))) ;; FIXME: Make sure that there's a transform for ;; (MEMBER SYMBOL ..) into MEMQ. ;; FIXME: Note that when/if I make SHARE operation to shared @@ -961,7 +958,7 @@ ;; '(:BOTH) tail sublists. (let ((when (transform-when transform))) (not (or (eq when :both) - (eq when (if *byte-compiling* :byte :native))))) + (eq when :native)))) t) ((or (not constrained) (valid-function-use node type :strict-result t)) @@ -1276,7 +1273,6 @@ leaf var)) t))))) ((and (null (rest (leaf-refs var))) - (not *byte-compiling*) (substitute-single-use-continuation arg var))) (t (propagate-to-refs var (continuation-type arg)))))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index e0ca8fc..ff4ef10 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1273,17 +1273,15 @@ (def-ir1-translator progv ((vars vals &body body) start cont) (ir1-convert start cont - (if (byte-compiling) - `(%progv ,vars ,vals #'(lambda () ,@body)) - (once-only ((n-save-bs '(%primitive current-binding-pointer))) - `(unwind-protect - (progn - (mapc #'(lambda (var val) - (%primitive bind val var)) - ,vars - ,vals) - ,@body) - (%primitive unbind-to-here ,n-save-bs)))))) + (once-only ((n-save-bs '(%primitive current-binding-pointer))) + `(unwind-protect + (progn + (mapc #'(lambda (var val) + (%primitive bind val var)) + ,vars + ,vals) + ,@body) + (%primitive unbind-to-here ,n-save-bs))))) ;;;; non-local exit diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index fefd236..0baae50 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -99,11 +99,7 @@ (predicate-type nil :type (or ctype null)) ;; If non-null, use this function to annotate the known call for the byte ;; compiler. If it returns NIL, then change the call to :full. - (byte-annotate nil :type (or function null)) - ;; If non-null, use this function to generate the byte code for this known - ;; call. This function can only give up if there is a byte-annotate function - ;; that arranged for the functional to be pushed onto the stack. - (byte-compile nil :type (or function null))) + (byte-annotate nil :type (or function null))) (defprinter (function-info) (transforms :test transforms) @@ -113,8 +109,7 @@ (ir2-convert :test ir2-convert) (templates :test templates) (predicate-type :test predicate-type) - (byte-annotate :test byte-annotate) - (byte-compile :test byte-compile)) + (byte-annotate :test byte-annotate)) ;;;; interfaces to defining macros diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 6ac6bc2..254b64b 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -30,38 +30,6 @@ *last-source-form* *last-format-string* *last-format-args* *last-message-count* *lexenv*)) -;;; FIXME: byte compiler to be removed completely -(defvar *byte-compile-default* nil - #!+sb-doc - "the default value for the :BYTE-COMPILE argument to COMPILE-FILE") - -(defvar *byte-compile-top-level* - #| - #-sb-xc-host t - #+sb-xc-host nil ; since the byte compiler isn't supported in cross-compiler - |# - nil ; FIXME: byte compiler to be removed completely - #!+sb-doc - "Similar to *BYTE-COMPILE-DEFAULT*, but controls the compilation of top-level - forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE - (the default.) When true, we decide to byte-compile.") - -;;; the value of the :BYTE-COMPILE argument which was passed to the -;;; compiler -(defvar *byte-compile* - nil #|:maybe|#) ; FIXME: byte compiler to be removed completely - -;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when -;;; native compiling. During IR1 conversion this can also be :MAYBE, -;;; in which case we must look at the policy; see #'BYTE-COMPILING. -(defvar *byte-compiling* - nil #|:maybe|#) ; FIXME: byte compiler to be removed completely - -(declaim (type (member t nil :maybe) - *byte-compile* - *byte-compiling* - *byte-compile-default*)) - (defvar *check-consistency* nil) (defvar *all-components*) @@ -382,8 +350,8 @@ (ir1-finalize component) (values)) -(defun native-compile-component (component) - (/show "entering NATIVE-COMPILE-COMPONENT") +(defun %compile-component (component) + (/show "entering %COMPILE-COMPONENT") (let ((*code-segment* nil) (*elsewhere* nil)) (maybe-mumble "GTN ") @@ -475,34 +443,9 @@ ;; We're done, so don't bother keeping anything around. (setf (component-info component) nil) - (/show "leaving NATIVE-COMPILE-COMPONENT") + (/show "leaving %COMPILE-COMPONENT") (values)) -(defun policy-byte-compile-p (thing) - nil - ;; FIXME: byte compiler to be removed completely - #| - (policy thing - (and (zerop speed) - (<= debug 1))) - |#) - -;;; Return our best guess for whether we will byte compile code -;;; currently being IR1 converted. This is only a guess because the -;;; decision is made on a per-component basis. -;;; -;;; FIXME: This should be called something more mnemonic, e.g. -;;; PROBABLY-BYTE-COMPILING -(defun byte-compiling () - nil - ;; FIXME: byte compiler to be removed completely - #| - (if (eq *byte-compiling* :maybe) - (or (eq *byte-compile* t) - (policy-byte-compile-p *lexenv*)) - (and *byte-compile* *byte-compiling*)) - |#) - ;;; Delete components with no external entry points before we try to ;;; generate code. Unreachable closures can cause IR2 conversion to ;;; puke on itself, since it is the reference to the closure which @@ -520,24 +463,10 @@ (leaf-refs fun)) (return)))))) -(defun byte-compile-this-component-p (component) - nil - ;; FIXME: byte compiler to be removed completely - #| - (ecase *byte-compile* - ((t) t) - ((nil) nil) - ((:maybe) - (every #'policy-byte-compile-p (component-lambdas component)))) - |#) - (defun compile-component (component) - (let* ((*component-being-compiled* component) - (*byte-compiling* (byte-compile-this-component-p component))) + (let* ((*component-being-compiled* component)) (when sb!xc:*compile-print* - (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: " - *byte-compiling* - (component-name component))) + (compiler-mumble "~&; compiling ~A: " (component-name component))) (ir1-phases component) @@ -550,9 +479,7 @@ (unless (eq (block-next (component-head component)) (component-tail component)) - (if *byte-compiling* - (byte-compile-component component) - (native-compile-component component)))) + (%compile-component component))) (clear-constant-info) @@ -1276,10 +1203,7 @@ force-p)) (multiple-value-bind (component tll) (merge-top-level-lambdas pending) (setq *pending-top-level-lambdas* ()) - (let ((*byte-compile* (if (eq *byte-compile* :maybe) - *byte-compile-top-level* - *byte-compile*))) - (compile-component component)) + (compile-component component) (clear-ir1-info component) (object-call-top-level-lambda tll)))) (values)) @@ -1335,22 +1259,18 @@ (when (pre-environment-analyze-top-level component) (setq top-level-closure t))) - (let ((*byte-compile* - (if (and top-level-closure (eq *byte-compile* :maybe)) - nil - *byte-compile*))) - (dolist (component components) - (compile-component component) - (when (replace-top-level-xeps component) - (setq top-level-closure t))) + (dolist (component components) + (compile-component component) + (when (replace-top-level-xeps component) + (setq top-level-closure t))) - (when *check-consistency* - (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) + (when *check-consistency* + (maybe-mumble "[check]~%") + (check-ir1-consistency *all-components*)) - (if load-time-value-p - (compile-load-time-value-lambda lambdas) - (compile-top-level-lambdas lambdas top-level-closure))) + (if load-time-value-p + (compile-load-time-value-lambda lambdas) + (compile-top-level-lambdas lambdas top-level-closure)) (mapc #'clear-ir1-info components) (clear-stuff))) @@ -1483,9 +1403,7 @@ ;; extensions (trace-file nil) - ((:block-compile *block-compile-argument*) nil) - ;; FIXME: byte compiler to be removed completely - #+nil ((:byte-compile *byte-compile*) *byte-compile-default*)) + ((:block-compile *block-compile-argument*) nil)) #!+sb-doc "Compile INPUT-FILE, producing a corresponding fasl file and returning @@ -1528,8 +1446,7 @@ :output-file output-file)) (setq fasl-output (open-fasl-output output-file-name - (namestring input-pathname) - (eq *byte-compile* t)))) + (namestring input-pathname)))) (when trace-file (let* ((default-trace-file-pathname (make-pathname :type "trace" :defaults input-pathname)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 35b35b1..ca49cc1 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -62,7 +62,7 @@ ;;; Translate CxR into CAR/CDR combos. (defun source-transform-cxr (form) - (if (or (byte-compiling) (/= (length form) 2)) + (if (/= (length form) 2) (values nil t) (let ((name (symbol-name (car form)))) (do ((i (- (length name) 2) (1- i)) diff --git a/src/compiler/target-byte-comp.lisp b/src/compiler/target-byte-comp.lisp deleted file mode 100644 index 65f9f3c..0000000 --- a/src/compiler/target-byte-comp.lisp +++ /dev/null @@ -1,278 +0,0 @@ -;;;; This file contains the noise to byte-compile stuff. It uses the -;;;; same front end as the real compiler, but generates byte code -;;;; instead of native code. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!C") - -;;; Generate trace file output for the byte compiler back end. -;;; -;;; (Note: As of sbcl-0.6.7, this is target-only code not because it's -;;; logically target-only, but just because it's still implemented in -;;; terms of SAPs.) -(defun describe-byte-component (component xeps segment *standard-output*) - (format t "~|~%;;;; byte component ~S~2%" (component-name component)) - (format t ";;; functions:~%") - (dolist (fun (component-lambdas component)) - (when (leaf-name fun) - (let ((info (leaf-info fun))) - (when info - (format t "~6D: ~S~%" - (sb!assem:label-position (byte-lambda-info-label info)) - (leaf-name fun)))))) - - (format t "~%;;;disassembly:~2%") - (collect ((eps) - (chunks)) - (dolist (x xeps) - (let ((xep (cdr x))) - (etypecase xep - (simple-byte-function - (eps (simple-byte-function-entry-point xep))) - (hairy-byte-function - (dolist (ep (hairy-byte-function-entry-points xep)) - (eps ep)) - (when (hairy-byte-function-more-args-entry-point xep) - (eps (hairy-byte-function-more-args-entry-point xep))))))) - ;; In CMU CL, this was - ;; (SB!ASSEM:SEGMENT-MAP-OUTPUT - ;; SEGMENT - ;; #'(LAMBDA (SAP BYTES) (CHUNKS (CONS SAP BYTES)))) - ;; -- WHN 19990811 - (sb!assem:on-segment-contents-vectorly segment - (lambda (chunk) (chunks chunk))) - (flet ((chunk-n-bytes (chunk) (length chunk))) - (let* ((total-bytes (reduce #'+ (chunks) :key #'chunk-n-bytes)) - ;; FIXME: It's not clear that BUF has to be a SAP instead - ;; of a nice high-level, safe, friendly vector. Perhaps - ;; this code could be rewritten to use ordinary indices and - ;; vectors instead of SAP references to chunks of raw - ;; system memory? Failing that, the DEALLOCATE-SYSTEM-MEMORY - ;; operation below should probably be tied to the - ;; allocation here with an UNWIND-PROTECT relationship. - (buf (allocate-system-memory total-bytes))) - (let ((offset 0)) - (dolist (chunk (chunks)) - (let ((chunk-n-bits (* (chunk-n-bytes chunk) sb!vm:byte-bits))) - (declare (type (simple-array (unsigned-byte 8)) chunk)) - (copy-byte-vector-to-system-area chunk buf offset) - (incf offset chunk-n-bits)))) - (disassem-byte-sap buf - total-bytes - (map 'vector - (lambda (x) - (if (constant-p x) - (constant-value x) - x)) - (byte-component-info-constants - (component-info component))) - (sort (eps) #'<)) - (terpri) - (deallocate-system-memory buf total-bytes) - (values))))) - -;;; Given a byte-compiled function, disassemble it to standard output. -(defun disassem-byte-fun (xep) - (declare (optimize (inhibit-warnings 3))) - (disassem-byte-component - (byte-function-component xep) - (etypecase xep - (simple-byte-function - (list (simple-byte-function-entry-point xep))) - (hairy-byte-function - (sort (copy-list - (if (hairy-byte-function-more-args-entry-point xep) - (cons (hairy-byte-function-more-args-entry-point xep) - (hairy-byte-function-entry-points xep)) - (hairy-byte-function-entry-points xep))) - #'<))))) - -;;; Given a byte-compiled component, disassemble it to standard -;;; output. EPS is a list of the entry points. -(defun disassem-byte-component (component &optional (eps '(0))) - (let* ((bytes (* (code-header-ref component sb!vm:code-code-size-slot) - sb!vm:word-bytes)) - (num-consts (- (get-header-data component) - sb!vm:code-constants-offset)) - (consts (make-array num-consts))) - (dotimes (i num-consts) - (setf (aref consts i) - (code-header-ref component (+ i sb!vm:code-constants-offset)))) - (without-gcing - (disassem-byte-sap (code-instructions component) bytes - consts eps)) - (values))) - -;;; Disassemble byte code from a SAP and constants vector. -(defun disassem-byte-sap (sap bytes constants eps) - (declare (optimize (inhibit-warnings 3))) - (let ((index 0)) - (declare (type index index)) - (labels ((newline () - (format t "~&~4D:" index)) - (next-byte () - (let ((byte (sap-ref-8 sap index))) - (format t " ~2,'0X" byte) - (incf index) - byte)) - (extract-24-bits () - (logior (ash (next-byte) 16) - (ash (next-byte) 8) - (next-byte))) - (extract-extended-op () - (let ((byte (next-byte))) - (if (= byte 255) - (extract-24-bits) - byte))) - (extract-4-bit-op (byte) - (let ((4-bits (ldb (byte 4 0) byte))) - (if (= 4-bits 15) - (extract-extended-op) - 4-bits))) - (extract-3-bit-op (byte) - (let ((3-bits (ldb (byte 3 0) byte))) - (if (= 3-bits 7) - :var - 3-bits))) - (extract-branch-target (byte) - (if (logbitp 0 byte) - (let ((disp (next-byte))) - (if (logbitp 7 disp) - (+ index disp -256) - (+ index disp))) - (extract-24-bits))) - (note (string &rest noise) - (format t " ~14T~?" string noise)) - (get-constant (index) - (if (< -1 index (length constants)) - (aref constants index) - ""))) - (loop - (unless (< index bytes) - (return)) - - (when (eql index (first eps)) - (newline) - (pop eps) - (let ((frame-size - (let ((byte (next-byte))) - (if (< byte 255) - (* byte 2) - (logior (ash (next-byte) 16) - (ash (next-byte) 8) - (next-byte)))))) - (note "entry point, frame-size=~D~%" frame-size))) - - (newline) - (let ((byte (next-byte))) - (macrolet ((dispatch (&rest clauses) - `(cond ,@(mapcar (lambda (clause) - (destructuring-bind - ((mask match) &body body) - clause - `((= (logand byte ,mask) ,match) - ,@body))) - clauses) - (t (error "disassembly failure for bytecode ~X" - byte))))) - (dispatch - ((#b11110000 #b00000000) - (let ((op (extract-4-bit-op byte))) - (note "push-local ~D" op))) - ((#b11110000 #b00010000) - (let ((op (extract-4-bit-op byte))) - (note "push-arg ~D" op))) - ((#b11110000 #b00100000) - ;; FIXME: could use WITH-PRINT-RESTRICTIONS here and in - ;; next clause (or just in LABELS NOTE) instead of - ;; hand-rolling values in each case here - (let ((*print-level* 3) - (*print-lines* 2)) - (note "push-const ~S" (get-constant (extract-4-bit-op byte))))) - ((#b11110000 #b00110000) - (let ((op (extract-4-bit-op byte)) - (*print-level* 3) - (*print-lines* 2)) - (note "push-sys-const ~S" - (svref *system-constants* op)))) - ((#b11110000 #b01000000) - (let ((op (extract-4-bit-op byte))) - (note "push-int ~D" op))) - ((#b11110000 #b01010000) - (let ((op (extract-4-bit-op byte))) - (note "push-neg-int ~D" (- (1+ op))))) - ((#b11110000 #b01100000) - (let ((op (extract-4-bit-op byte))) - (note "pop-local ~D" op))) - ((#b11110000 #b01110000) - (let ((op (extract-4-bit-op byte))) - (note "pop-n ~D" op))) - ((#b11110000 #b10000000) - (let ((op (extract-3-bit-op byte))) - (note "~:[~;named-~]call, ~D args" - (logbitp 3 byte) op))) - ((#b11110000 #b10010000) - (let ((op (extract-3-bit-op byte))) - (note "~:[~;named-~]tail-call, ~D args" - (logbitp 3 byte) op))) - ((#b11110000 #b10100000) - (let ((op (extract-3-bit-op byte))) - (note "~:[~;named-~]multiple-call, ~D args" - (logbitp 3 byte) op))) - ((#b11111000 #b10110000) - ;; local call - (let ((op (extract-3-bit-op byte)) - (target (extract-24-bits))) - (note "local call ~D, ~D args" target op))) - ((#b11111000 #b10111000) - ;; local tail-call - (let ((op (extract-3-bit-op byte)) - (target (extract-24-bits))) - (note "local tail-call ~D, ~D args" target op))) - ((#b11111000 #b11000000) - ;; local-multiple-call - (let ((op (extract-3-bit-op byte)) - (target (extract-24-bits))) - (note "local multiple-call ~D, ~D args" target op))) - ((#b11111000 #b11001000) - ;; return - (let ((op (extract-3-bit-op byte))) - (note "return, ~D vals" op))) - ((#b11111110 #b11010000) - ;; branch - (note "branch ~D" (extract-branch-target byte))) - ((#b11111110 #b11010010) - ;; if-true - (note "if-true ~D" (extract-branch-target byte))) - ((#b11111110 #b11010100) - ;; if-false - (note "if-false ~D" (extract-branch-target byte))) - ((#b11111110 #b11010110) - ;; if-eq - (note "if-eq ~D" (extract-branch-target byte))) - ((#b11111000 #b11011000) - ;; XOP - (let* ((low-3-bits (extract-3-bit-op byte)) - (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits) - *xop-names*))) - (note "xop ~A~@[ ~D~]" - xop - (case xop - ((catch go unwind-protect) - (extract-24-bits)) - ((type-check push-n-under) - (get-constant (extract-extended-op))))))) - - ((#b11100000 #b11100000) - ;; inline - (note "inline ~A" - (inline-function-info-function - (svref *inline-functions* (ldb (byte 5 0) byte)))))))))))) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 1fb8c87..d3544ae 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1533,7 +1533,7 @@ (stream *standard-output*) (use-labels t)) #!+sb-doc - "Disassemble the machine code associated with OBJECT, which can be a + "Disassemble the compiled code associated with OBJECT, which can be a function, a lambda expression, or a symbol with a function definition. If it is not already compiled, the compiler is called to produce something to disassemble." @@ -1541,13 +1541,9 @@ (type (or (member t) stream) stream) (type (member t nil) use-labels)) (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") - (let ((fun (compiled-function-or-lose object))) - (if nil #|(typep fun 'sb!kernel:byte-function)|# ; FIXME: byte compile to go away completely - (sb!c:disassem-byte-fun fun) - ;; We can't detect closures, so be careful. - (disassemble-function (fun-self fun) - :stream stream - :use-labels use-labels))) + (disassemble-function (compiled-function-or-lose object) + :stream stream + :use-labels use-labels) nil)) ;;; Disassembles the given area of memory starting at ADDRESS and diff --git a/src/compiler/target-dump.lisp b/src/compiler/target-dump.lisp index f18255a..a948275 100644 --- a/src/compiler/target-dump.lisp +++ b/src/compiler/target-dump.lisp @@ -101,24 +101,3 @@ (dump-unsigned-32 mid-bits file) (dump-unsigned-32 high-bits file) (dump-integer-as-n-bytes exp-bits 4 file))) - -;;;; dumping things which don't exist in portable ANSI Common Lisp - -;;; FIXME: byte compiler to go away completely -#| -;;; Dump a BYTE-FUNCTION object. We dump the layout and -;;; funcallable-instance info, but rely on the loader setting up the -;;; correct funcallable-instance-function. -(defun dump-byte-function (xep code-handle file) - (let ((nslots (- (get-closure-length xep) - ;; 1- for header - (1- sb!vm:funcallable-instance-info-offset)))) - (dotimes (i nslots) - (if (zerop i) - (dump-push code-handle file) - (dump-object (%funcallable-instance-info xep i) file))) - (dump-object (%funcallable-instance-layout xep) file) - (dump-fop 'fop-make-byte-compiled-function file) - (dump-byte nslots file)) - (values)) -|# \ No newline at end of file diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index e569f47..74940f5 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -12,9 +12,6 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -;;; FIXME: Many of the functions in this file could probably be -;;; byte-compiled, since they're one-pass, cons-heavy code. - (in-package "SB!C") ;;;; type predicate translation @@ -387,16 +384,6 @@ ;;; then we also check whether the layout for the object is invalid ;;; and signal an error if so. Otherwise, look up the indirect ;;; class-cell and call CLASS-CELL-TYPEP at runtime. -;;; -;;; KLUDGE: The :WHEN :BOTH option here is probably a suboptimal -;;; solution to the problem of %INSTANCE-TYPEP forms in byte compiled -;;; code; it'd probably be better just to have %INSTANCE-TYPEP forms -;;; never be generated in byte compiled code, or maybe to have a DEFUN -;;; %INSTANCE-TYPEP somewhere to handle them if they are. But it's not -;;; terribly important because mostly, %INSTANCE-TYPEP forms *aren't* -;;; generated in byte compiled code. (As of sbcl-0.6.5, they could -;;; sometimes be generated when byte compiling inline functions, but -;;; it's quite uncommon.) -- WHN 20000523 (deftransform %instance-typep ((object spec) (* *) * :node node :when :both) (aver (constant-continuation-p spec)) (let* ((spec (continuation-value spec)) @@ -496,10 +483,7 @@ ;;; If the type is TYPE= to a type that has a predicate, then expand ;;; to that predicate. Otherwise, we dispatch off of the type's type. ;;; These transformations can increase space, but it is hard to tell -;;; when, so we ignore policy and always do them. When byte-compiling, -;;; we only do transforms that have potential for control -;;; simplification. Instance type tests are converted to -;;; %INSTANCE-TYPEP to allow type propagation. +;;; when, so we ignore policy and always do them. (def-source-transform typep (object spec) ;; KLUDGE: It looks bad to only do this on explicitly quoted forms, ;; since that would overlook other kinds of constants. But it turns @@ -526,17 +510,16 @@ (cadr spec)) `(%typep ,object ,spec)) (t nil)) - (and (not (byte-compiling)) - (typecase type - (numeric-type - (source-transform-numeric-typep object type)) - (sb!xc:class - `(%instance-typep ,object ,spec)) - (array-type - (source-transform-array-typep object type)) - (cons-type - (source-transform-cons-typep object type)) - (t nil))) + (typecase type + (numeric-type + (source-transform-numeric-typep object type)) + (sb!xc:class + `(%instance-typep ,object ,spec)) + (array-type + (source-transform-array-typep object type)) + (cons-type + (source-transform-cons-typep object type)) + (t nil)) `(%typep ,object ,spec))) (values nil t))) diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 6395c9e..dc79fef 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -15,14 +15,6 @@ ;;; I wonder whether the separation of the disassembler from the ;;; virtual machine is valid or adds value. -;;; FIXME: In CMU CL, the code in this file seems to be fully -;;; compiled, not byte compiled. I'm not sure that's reasonable: -;;; there's a lot of code in this file, and considering the overall -;;; speed of the compiler, having some byte-interpretation overhead -;;; for every few bytes emitted doesn't seem likely to be noticeable. -;;; I'd like to see what happens if I come back and byte-compile this -;;; file. - ;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS. (setf sb!disassem:*disassem-inst-alignment-bytes* 1) diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index d9a4e2b..998d45c 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -26,8 +26,6 @@ (in-package "SB-PCL") -(declaim #.*optimize-byte-compilation*) - (defmethod slots-to-inspect ((class slot-class) (object slot-object)) (class-slots class)) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index dbe1094..0fd9df5 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -170,17 +170,7 @@ (error 'simple-type-error :datum fcn :expected-type 'generic-function - :format-control "internal error: unexpected function type") - ;; FIXME: byte compiler to go away completely - #| - (etypecase fcn - (sb-kernel:byte-closure - (set-function-name (sb-kernel:byte-closure-function fcn) - new-name)) - (sb-kernel:byte-function - (setf (sb-kernel:byte-function-name fcn) new-name))) - |# - ) + :format-control "internal error: bad function type")) fcn) (t ;; pw-- This seems wrong and causes trouble. Tests show diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 7c1eeab..29e4fa8 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -1857,15 +1857,6 @@ sniff_code_object(struct code *code, unsigned displacement) if (!check_code_fixups) return; - /* It's ok if it's byte compiled code. The trace table offset will - * be a fixnum if it's x86 compiled code - check. */ - if (code->trace_table_offset & 0x3) { - FSHOW((stderr, "/Sniffing byte compiled code object at %x.\n", code)); - return; - } - - /* Else it's x86 machine code. */ - ncode_words = fixnum_value(code->code_size); nheader_words = HeaderValue(*(lispobj *)code); nwords = ncode_words + nheader_words; @@ -2034,14 +2025,6 @@ apply_code_fixups(struct code *old_code, struct code *new_code) unsigned displacement = (unsigned)new_code - (unsigned)old_code; struct vector *fixups_vector; - /* It's OK if it's byte compiled code. The trace table offset will - * be a fixnum if it's x86 compiled code - check. */ - if (new_code->trace_table_offset & 0x3) { -/* FSHOW((stderr, "/byte compiled code object at %x\n", new_code)); */ - return; - } - - /* Else it's x86 machine code. */ ncode_words = fixnum_value(new_code->code_size); nheader_words = HeaderValue(*(lispobj *)new_code); nwords = ncode_words + nheader_words; @@ -5112,7 +5095,13 @@ verify_space(lispobj *start, size_t words) if (is_in_dynamic_space /* It's ok if it's byte compiled code. The trace * table offset will be a fixnum if it's x86 - * compiled code - check. */ + * compiled code - check. + * + * FIXME: #^#@@! lack of abstraction here.. + * This line can probably go away now that + * there's no byte compiler, but I've got + * too much to worry about right now to try + * to make sure. -- WHN 2001-10-06 */ && !(code->trace_table_offset & 0x3) /* Only when enabled */ && verify_dynamic_code_check) { diff --git a/src/runtime/purify.c b/src/runtime/purify.c index c706085..6612308 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -1041,19 +1041,6 @@ pscav_code(struct code*code) lispobj func; nwords = HeaderValue(code->header) + fixnum_value(code->code_size); - /* pw--The trace_table_offset slot can contain a list pointer. This - * occurs when the code object is a top level form that initializes - * a byte-compiled function. The fact that PURIFY was ignoring this - * slot may be a bug unrelated to the x86 port, except that TLF's - * normally become unreachable after the loader calls them and - * won't be seen by PURIFY at all!! */ - if(code->trace_table_offset & 0x3) -#if 0 - pscav(&code->trace_table_offset, 1, 0); -#else - code->trace_table_offset = NIL; /* limit lifetime */ -#endif - /* Arrange to scavenge the debug info later. */ pscav_later(&code->debug_info, 1); diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 7340682..99c6e28 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -426,7 +426,23 @@ ;; Compiling this requires fop definitions from code/fop.lisp and ;; trace table definitions from compiler/trace-table.lisp. - ("src/compiler/dump") + ("src/compiler/dump" + ;; FIXME: When building sbcl-0.pre7.14.flaky4.5 under sbcl-0.6.12.1 + ;; with :SB-SHOW on the target *FEATURES* list, cross-compilation of + ;; this file gives a WARNING in HEXSTR, + ;; Lisp error during constant folding: + ;; Argument X is not a REAL: NIL + ;; This seems to come from DEF!MACRO %WITH-ARRAY-DATA-MACRO code + ;; which looks like + ;; (cond (,end + ;; (unless (or ,unsafe? (<= ,end ,size)) + ;; ..)) + ;; ..) + ;; where the system is trying to constant-fold the <= form when the + ;; ,END binding is known to be NIL at compile time. Since the <= form + ;; is unreachable in that case, this shouldn't be signalling a WARNING; + ;; but as long as it is, we have to ignore it in order to go on. + :ignore-failure-p) ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp ("src/compiler/target-main" :not-host) @@ -565,20 +581,6 @@ ; from "code/pathname" ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" - ;; stuff for byte compilation - ;; - ;; This is mostly :NOT-HOST because even though byte code is - ;; "portable", it'd be hard to make it work on the cross-compilation - ;; host, because fundamental BYTE-FUNCTION-OR-CLOSURE types are - ;; implemented as FUNCALLABLE-INSTANCEs, and it's not obvious how to - ;; emulate those in a vanilla ANSI Common Lisp. - #| ; FIXME: byte compiler to go away completely - ("src/code/byte-types" :not-host) - ("src/compiler/byte-comp") - ("src/compiler/target-byte-comp" :not-host) - ("src/code/byte-interp" :not-host) ; needs byte-comp *SYSTEM-CONSTANT-CODES* - |# - ;; defines SB!DI:DO-DEBUG-FUNCTION-BLOCKS, needed by target-disassem.lisp ("src/code/debug-int" :not-host) @@ -628,9 +630,6 @@ ;; fundamental target macros (e.g. CL:DO and CL:DEFUN) and support ;; for them - ;; - ;; FIXME: Since a lot of this code is just macros, perhaps it should be - ;; byte compiled? ("src/code/defboot") ("src/code/destructuring-bind") ("src/code/early-setf") diff --git a/version.lisp-expr b/version.lisp-expr index aaf03e9..8e50609 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.48" +"0.pre7.49"