deleting old byte-compiler/byte-interpreter stuff..
..find . -name *byte*lisp | xargs rm
..find . -name *.lisp | xargs egrep -i 'byte.*comp'
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
; (while making load form for #<SB-IMPL::LOGICAL-HOST "XXX">)
; A logical host can't be dumped as a constant: #<SB-IMPL::LOGICAL-HOST "XXX">
-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:
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)
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
(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
--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,
"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"
+++ /dev/null
-;;;; 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)))
-\f
-;;; 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) *))))))
-\f
-;;;; 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))
-\f
-;;;; 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))))
-\f
-;;;; 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))
-\f
-;;;; 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))
-\f
-;;;; 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))
-\f
-;;;; 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))
-\f
-;;;; 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))
-\f
-;;;; funny functions
-
-;;; (used both by the byte interpreter and by the IR1 interpreter)
-(defun %progv (vars vals fun)
- (progv vars vals
- (funcall fun)))
-\f
-;;;; 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)))
-\f
-;;;; 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)))
-\f
-;;;; 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)))))
-
+++ /dev/null
-;;;; 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")
-\f
-;;;; 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))
-\f
-;;;; 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
- ;; #<FUNCTION ..> or as #<COMPILED-FUNCTION ..>, 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))
-;;;; 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.
(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*
;;; 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))
;;;; files for more information.
(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
-
-(declaim #.*optimize-byte-compilation*)
-
\f
(defvar *describe-indentation-step* 3
#+sb-doc
(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)
(%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))
(%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.
(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
(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 ()
(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))
-|#
\f
;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code
;;;; was sufficiently stale that the functions it called were no
(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"
(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
(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))
#!-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
\f
;;;; power functions
;;; 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)
;;; 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)
;;; 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*)
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)
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)))
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)))
;;; 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)
;;; 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
:format-control "~@<~A: ~2I~_~A~:>"
:format-arguments (list prefix-string (strerror errno))
other-condition-args))
-\f
-;;;; 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))))
;;; 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
;;; 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))
(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)
((#.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)))))
\f
;;;; 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)
;;; 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))))
\f
;;;; miscellaneous interfaces
(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)
;;; 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
\f
;;;; 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")
;;; 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))
;; (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
;;; 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-)
(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)
+++ /dev/null
-;;;; 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.
-\f
-;;;; 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))))))
-\f
-;;;; 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))))
-\f
-;;;; 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))
-\f
-;;;; 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)))
-\f
-;;;; 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))
-\f
-;;;; 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))
-\f
-;;;; 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))
-\f
-;;;; 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))
-\f
-;;; 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))
-\f
-;;;; 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))
-\f
-;;;; 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~%")))))))
(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
: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)
(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
(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))
(,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
"-PRINTER"))
(make-printer-defun printer-source funstate name)))))
\f
-;;;; 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)))
(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 ()
`(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))
))
`(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)
;;; 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
;; 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)))
(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)))))
(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)))
;; 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
(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)
(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
(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
(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
;; '(: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))
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))))))
(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)))))
\f
;;;; non-local exit
(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)
(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))
\f
;;;; interfaces to defining macros
*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*)
(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 ")
;; 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
(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)
(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)
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))
(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)))
;; 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
: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))
;;; 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))
+++ /dev/null
-;;;; 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)
- "<bogus 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))))))))))))
(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."
(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
(dump-unsigned-32 mid-bits file)
(dump-unsigned-32 high-bits file)
(dump-integer-as-n-bytes exp-bits 4 file)))
-\f
-;;;; 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
;;;; 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")
\f
;;;; type predicate translation
;;; 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))
;;; 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
(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)))
\f
;;; 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)
(in-package "SB-PCL")
-(declaim #.*optimize-byte-compilation*)
-
(defmethod slots-to-inspect ((class slot-class) (object slot-object))
(class-slots class))
(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
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;
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;
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) {
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);
;; 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)
; 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)
;; 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")
;;; 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"
projects / sbcl.git / commitdiff