X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fbyte-comp.lisp;h=63e9885a58a9b11c75f456f4a788126486ec0bf8;hb=947522ee16a30d43466c8f86efacee7003e5d85f;hp=db5be907906aa8b65761fd39e65cfc211b9433e0;hpb=4ea1b7a6961e6b2d336603a04e448db052993244;p=sbcl.git diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index db5be90..63e9885 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -12,12 +12,6 @@ (in-package "SB!C") -;;;; the fasl file format that we use -(defconstant byte-fasl-file-version 3) -;;; 1 = before about sbcl-0.6.9.8 -;;; 2 = merged package SB-CONDITIONS into SB-KERNEL around sbcl-0.6.9.8 -;;; 3 = deleted obsolete CONS-UNIQUE-TAG bytecode in sbcl-0.6.11.8 - ;;; ### 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)) @@ -362,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)) @@ -467,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) @@ -488,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))) @@ -610,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) @@ -640,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))) @@ -705,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)) @@ -756,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)) @@ -779,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 @@ -790,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) @@ -1003,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)) @@ -1012,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. @@ -1071,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 @@ -1083,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 () @@ -1207,15 +1203,16 @@ (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)))) @@ -1311,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)) @@ -1367,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 @@ -1375,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))) @@ -1422,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)) @@ -1631,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) @@ -1642,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) @@ -1650,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) @@ -1662,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)) @@ -1674,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) @@ -1687,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) @@ -1709,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 @@ -1730,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)) @@ -1752,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 @@ -1762,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) @@ -1776,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) @@ -1789,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)) @@ -1798,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 @@ -1810,10 +1807,10 @@ (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 @@ -1865,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) @@ -1931,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. @@ -1972,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*))