(in-package "SB!C")
-;;;; the fasl file format that we use
-(defconstant byte-fasl-file-version 2)
-;;; 1 = before about sbcl-0.6.9.8
-;;; 2 = merged package SB-CONDITIONS into SB-KERNEL around sbcl-0.6.9.8
-
;;; ### remaining work:
;;;
;;; - add more inline operations.
(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))))))
(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))
;;; 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
(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)
\f
;;;; 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
(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
(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))
;; 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))
(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)
(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)))
(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)
(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))
(incf fixed results))))))
(flush-fixed)))
(when (pops)
- (assert pred)
+ (aver pred)
(let ((cleanup-block
(insert-cleanup-code pred block
(continuation-next (block-start block))
(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
;;; 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)
(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))
(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.
;;; 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
(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 ()
(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
;; 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
- ;; 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)
- (unless (eql values 0)
- ;; Someone wants the value, so copy it.
- (output-do-xop segment 'dup))
- (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)))))
+ ;; 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))
(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))
(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
(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)))
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))
(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)
(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)
(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)
(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))
(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)
(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)
(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
(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))
(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
(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)
(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)
(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))
(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
(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)
(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*))
projects / sbcl.git / blobdiff