X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fbyte-comp.lisp;h=63e9885a58a9b11c75f456f4a788126486ec0bf8;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=55185a693284c195bd9aad398b1d1c58a3dd99eb;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index 55185a6..63e9885 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -12,12 +12,6 @@ (in-package "SB!C") -(file-comment - "$Header$") - -;;;; the fasl file format that we use -(defconstant byte-fasl-file-version 1) - ;;; ### remaining work: ;;; ;;; - add more inline operations. @@ -78,7 +72,7 @@ (declare (type sb!assem:segment segment) (ignore posn)) (let ((target (sb!assem:label-position label))) - (assert (<= 0 target (1- (ash 1 24)))) + (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)))))) @@ -116,7 +110,7 @@ (declare (type sb!assem:segment segment) (ignore posn)) (let ((target (sb!assem:label-position label))) - (assert (<= 0 target (1- (ash 1 24)))) + (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)) @@ -149,7 +143,8 @@ (def-system-constant 14 '(%fdefinition-marker% . %negate)) (def-system-constant 15 '(%fdefinition-marker% . %%defun)) (def-system-constant 16 '(%fdefinition-marker% . %%defmacro)) - (def-system-constant 17 '(%fdefinition-marker% . %%defconstant)) + ;; no longer used as of sbcl-0.pre7: + #+nil (def-system-constant 17 '(%fdefinition-marker% . %%defconstant)) (def-system-constant 18 '(%fdefinition-marker% . length)) (def-system-constant 19 '(%fdefinition-marker% . equal)) (def-system-constant 20 '(%fdefinition-marker% . append)) @@ -194,7 +189,7 @@ ;;; number of bits devoted to coding byte-inline functions. (eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct inline-function-info + (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 @@ -223,7 +218,6 @@ (setf-symbol-value (t symbol) (values)) (%byte-special-bind (t symbol) (values)) (%byte-special-unbind () (values)) - (cons-unique-tag () t) ; obsolete... (%negate (fixnum) fixnum) (< (fixnum fixnum) t) (> (fixnum fixnum) t) @@ -270,10 +264,10 @@ ;;;; annotations hung off the IR1 while compiling -(defstruct byte-component-info +(defstruct (byte-component-info (:copier nil)) (constants (make-array 10 :adjustable t :fill-pointer 0))) -(defstruct byte-lambda-info +(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 @@ -282,16 +276,17 @@ (defun block-interesting (block) (byte-lambda-info-interesting (lambda-info (block-home-lambda block)))) -(defstruct byte-lambda-var-info +(defstruct (byte-lambda-var-info (:copier nil)) (argp nil :type (member t nil)) (offset 0 :type index)) -(defstruct byte-nlx-info +(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 @@ -338,7 +333,8 @@ (defstruct (byte-continuation-info (:include sset-element) (:constructor make-byte-continuation-info - (continuation results placeholders))) + (continuation results placeholders)) + (:copier nil)) (continuation (required-argument) :type continuation) (results (required-argument) :type (or (member :fdefinition :eq-test :unknown) index)) @@ -361,7 +357,7 @@ ;; times on the same continuation. So we can't assert that we ;; haven't done it. #+nil - (assert (null (continuation-info cont))) + (aver (null (continuation-info cont))) (setf (continuation-info cont) (make-byte-continuation-info cont results placeholders)) (values)) @@ -466,7 +462,7 @@ (if (continuation-function-name fun) :fdefinition 1)))) (cond ((mv-combination-p call) (cond ((eq name '%throw) - (assert (= (length args) 2)) + (aver (= (length args) 2)) (annotate-continuation (first args) 1) (annotate-continuation (second args) :unknown) (setf (node-tail-p call) nil) @@ -487,7 +483,7 @@ (let ((leaf (ref-leaf (continuation-use fun)))) (and (slot-accessor-p leaf) (or (policy call (zerop safety)) - (not (find 't args + (not (find t args :key #'continuation-type-check))) (if (consp name) (not (continuation-dest (node-cont call))) @@ -609,7 +605,7 @@ (consume (cont) (cond ((not (or (eq cont :nlx-entry) (interesting cont)))) (stack - (assert (eq (car stack) cont)) + (aver (eq (car stack) cont)) (pop stack)) (t (adjoin-cont cont total-consumes) @@ -639,8 +635,8 @@ (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. + ;; 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))) @@ -704,10 +700,10 @@ (let ((new-stack stack)) (dolist (cont stuff) (cond ((eq cont :nlx-entry) - (assert (find :nlx-entry new-stack)) + (aver (find :nlx-entry new-stack)) (setq new-stack (remove :nlx-entry new-stack :count 1))) (t - (assert (eq (car new-stack) cont)) + (aver (eq (car new-stack) cont)) (pop new-stack)))) new-stack)) @@ -755,7 +751,7 @@ (incf fixed results)))))) (flush-fixed))) (when (pops) - (assert pred) + (aver pred) (let ((cleanup-block (insert-cleanup-code pred block (continuation-next (block-start block)) @@ -778,7 +774,7 @@ (t ;; We have already processed the successors of this block. Just ;; make sure we thing the stack is the same now as before. - (assert (equal (byte-block-info-start-stack info) stack))))) + (aver (equal (byte-block-info-start-stack info) stack))))) (values)) ;;; Do lifetime flow analysis on values pushed on the stack, then call @@ -789,6 +785,7 @@ ;;; 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) @@ -856,29 +853,31 @@ (defvar *byte-component-info*) -(eval-when (#+sb-xc :compile-toplevel :load-toplevel :execute) - (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)) +;;; 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) @@ -1000,8 +999,8 @@ (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. - (assert indirect) - (assert (not make-value-cells)) + (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)) @@ -1009,7 +1008,7 @@ (let* ((pushp (and indirect (not make-value-cells))) (byte-code (if pushp byte-push-local byte-pop-local)) (info (leaf-info var))) - (assert (not (byte-lambda-var-info-argp info))) + (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. @@ -1068,7 +1067,7 @@ ;;; 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 (w/o the placeholders.) +;;; values (without the placeholders.) ;;; ;;; Somewhat unrelatedly, we also push placeholders for deleted ;;; arguments to local calls. Although we check first, the actual @@ -1080,7 +1079,7 @@ (let ((desired (byte-continuation-info-results info)) (placeholders (byte-continuation-info-placeholders info))) (unless (zerop placeholders) - (assert (eql desired (1+ placeholders))) + (aver (eql desired (1+ placeholders))) (setq desired 1)) (flet ((do-check () @@ -1204,28 +1203,33 @@ (leaf (ref-leaf ref))) (cond ((eq values :fdefinition) - (assert (and (global-var-p leaf) - (eq (global-var-kind leaf) - :global-function))) + (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 (combination-args (continuation-dest cont))) + (= (length (basic-combination-args + (continuation-dest cont))) 2)) found name)))) ((eql values 0) - ;; Real easy! + ;; really easy! nil) (t (etypecase leaf (constant - (output-push-constant-leaf segment leaf)) + (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* ((refered-env (lambda-environment leaf)) - (closure (environment-closure refered-env))) + (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))) @@ -1265,13 +1269,22 @@ ;; Someone wants the value, so copy it. (output-do-xop segment 'dup)) (etypecase leaf - (global-var + (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 - (output-set-lambda-var segment leaf (node-environment set)))) + ;; 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)) @@ -1295,7 +1308,7 @@ (output-set-lambda-var segment var env t)))) ((nil :optional :cleanup) ;; We got us a local call. - (assert (not (eq num-args :unknown))) + (aver (not (eq num-args :unknown))) ;; Push any trailing placeholder args... (dolist (x (reverse (basic-combination-args call))) (when x (return)) @@ -1351,7 +1364,7 @@ (cond (info ;; It's an inline function. - (assert (not (node-tail-p call))) + (aver (not (node-tail-p call))) (let* ((type (inline-function-info-type info)) (desired-args (function-type-nargs type)) (supplied-results @@ -1359,7 +1372,7 @@ (values-types (function-type-returns type)))) (leaf (ref-leaf (continuation-use (basic-combination-fun call))))) (cond ((slot-accessor-p leaf) - (assert (= num-args (1- desired-args))) + (aver (= num-args (1- desired-args))) (output-push-int segment (dsd-index (slot-accessor-slot leaf)))) (t (canonicalize-values segment desired-args num-args))) @@ -1406,10 +1419,10 @@ 0)) num-args segment) (return)) - (assert (member (byte-continuation-info-results - (continuation-info - (basic-combination-fun call))) - '(1 :fdefinition))) + (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)) @@ -1615,8 +1628,8 @@ (progn segment) ; ignorable. ;; We don't have to do anything, because everything is handled by ;; the IF byte-generator. - (assert (eq results :eq-test)) - (assert (eql num-args 2)) + (aver (eq results :eq-test)) + (aver (eql num-args 2)) (values)) (defoptimizer (values byte-compile) @@ -1626,7 +1639,7 @@ (defknown %byte-pop-stack (index) (values)) (defoptimizer (%byte-pop-stack byte-annotate) ((count) node) - (assert (constant-continuation-p count)) + (aver (constant-continuation-p count)) (annotate-continuation count 0) (annotate-continuation (basic-combination-fun node) 0) (setf (node-tail-p node) nil) @@ -1634,7 +1647,7 @@ (defoptimizer (%byte-pop-stack byte-compile) ((count) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) + (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) @@ -1646,7 +1659,7 @@ (defoptimizer (%special-bind byte-compile) ((var value) node results num-args segment) - (assert (and (eql num-args 1) (zerop results))) + (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)) @@ -1658,7 +1671,7 @@ (defoptimizer (%special-unbind byte-compile) ((var) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-do-inline-function segment '%byte-special-unbind)) (defoptimizer (%catch byte-annotate) ((nlx-info tag) node) @@ -1671,18 +1684,18 @@ (defoptimizer (%catch byte-compile) ((nlx-info tag) node results num-args segment) (progn node) ; ignore - (assert (and (= num-args 1) (zerop results))) + (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 - (assert (and (zerop num-args) (zerop results)))) + (aver (and (zerop num-args) (zerop results)))) (defoptimizer (%catch-breakup byte-compile) (() node results num-args segment) (progn node) ; ignore - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-do-xop segment 'breakup)) (defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node) @@ -1693,7 +1706,7 @@ (defoptimizer (%lexical-exit-breakup byte-compile) ((nlx-info) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (let ((nlx-info (continuation-value nlx-info))) (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) (:block @@ -1714,7 +1727,7 @@ (defoptimizer (%nlx-entry byte-compile) ((nlx-info) node results num-args segment) (progn node results) ; ignore - (assert (eql num-args 0)) + (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)) @@ -1736,7 +1749,7 @@ (defoptimizer (%unwind-protect byte-compile) ((nlx-info cleanup-fun) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-do-xop segment 'unwind-protect) (output-reference segment (byte-nlx-info-label @@ -1746,7 +1759,7 @@ (defoptimizer (%unwind-protect-breakup byte-compile) (() node results num-args segment) (progn node) ; ignore - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-do-xop segment 'breakup)) (defoptimizer (%continue-unwind byte-annotate) ((a b c) node) @@ -1760,8 +1773,8 @@ (defoptimizer (%continue-unwind byte-compile) ((a b c) node results num-args segment) (progn node) ; ignore - (assert (member results '(0 nil))) - (assert (eql num-args 0)) + (aver (member results '(0 nil))) + (aver (eql num-args 0)) (output-do-xop segment 'breakup)) (defoptimizer (%load-time-value byte-annotate) ((handle) node) @@ -1773,7 +1786,7 @@ (defoptimizer (%load-time-value byte-compile) ((handle) node results num-args segment) (progn node) ; ignore - (assert (zerop num-args)) + (aver (zerop num-args)) (output-push-load-time-constant segment :load-time-value (continuation-value handle)) (canonicalize-values segment results 1)) @@ -1782,7 +1795,7 @@ (defun make-xep-for (lambda) (flet ((entry-point-for (entry) (let ((info (lambda-info entry))) - (assert (byte-lambda-info-interesting info)) + (aver (byte-lambda-info-interesting info)) (sb!assem:label-position (byte-lambda-info-label info))))) (let ((entry (lambda-entry-function lambda))) (etypecase entry @@ -1794,17 +1807,22 @@ (dolist (var (nthcdr (optional-dispatch-max-args entry) (optional-dispatch-arglist entry))) (let ((arg-info (lambda-var-arg-info var))) - (assert arg-info) + (aver arg-info) (ecase (arg-info-kind arg-info) (:rest - (assert (not rest-arg-p)) + (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-keyword arg-info) + (keywords (list (arg-info-key arg-info) (if (constantp default) (eval default) nil) @@ -1844,9 +1862,9 @@ ;; 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 :external lambdas, so we don't need - ;; to allocate stack space. Also, we don't use the ``more'' entry, - ;; so we don't need code for it. + ;; We don't generate any code for :EXTERNAL lambdas, so we don't + ;; need to allocate stack space. Also, we don't use the ``more'' + ;; entry, so we don't need code for it. (cond ((or (eq (lambda-kind lambda) :external) (and (eq (lambda-kind lambda) :optional) @@ -1910,12 +1928,12 @@ ;; 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 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. + ;; 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. @@ -1951,13 +1969,12 @@ (xeps (generate-xeps component)) (constants (byte-component-info-constants (component-info component)))) - #!+sb-show (when *compiler-trace-output* (describe-component component *compiler-trace-output*) (describe-byte-component component xeps segment *compiler-trace-output*)) (etypecase *compile-object* - (fasl-file + (fasl-output (maybe-mumble "FASL") (fasl-dump-byte-component segment code-length constants xeps *compile-object*))