From f707c6491952bc1fcad2a37e1587d460185c0a78 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 24 Jul 1992 04:08:16 +0000 Subject: [PATCH] Initial revision --- compiler/byte-comp.lisp | 1685 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 1685 insertions(+) create mode 100644 compiler/byte-comp.lisp diff --git a/compiler/byte-comp.lisp b/compiler/byte-comp.lisp new file mode 100644 index 000000000..d70e3953d --- /dev/null +++ b/compiler/byte-comp.lisp @@ -0,0 +1,1685 @@ +;;; -*- Package: C -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/byte-comp.lisp,v 1.1 1992/07/24 04:08:16 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the noise to byte-compile stuff. It uses the +;;; same front end as the real compiler, but generates a byte-code instead +;;; of native code. +;;; +;;; Written by William Lott +;;; + +(in-package "C") + +;;; ### Remaining work: +;;; +;;; - Add type-testing noise. In other words, hack over checkgen to know +;;; about the byte-compiler. +;;; - Breakpoints/debugging info. +;;; + + +;;;; Stuff to emit noise. + +;;; Note: we use the regular assembler, but we don't use any ``instructions'' +;;; because there is no way to keep our byte-code instructions seperate from +;;; the instructions used by the native backend. Besides, we don't want to do +;;; any scheduling or anything like that, anyway. + +(declaim (inline output-byte)) +(defun output-byte (segment byte) + (declare (type new-assem:segment segment) + (type (unsigned-byte 8) byte)) + (new-assem:emit-byte segment byte)) + +;;; OUTPUT-BYTE-WITH-OPERAND -- internal. +;;; +;;; Output a byte, logior'ing in a 4 bit immediate constant. If that +;;; immediate won't fit, then emit it as the next 4 bytes. +;;; +(defun output-byte-with-operand (segment byte operand) + (declare (type new-assem:segment segment) + (type (unsigned-byte 8) byte) + (type (unsigned-byte 32) operand)) + (cond ((<= operand 14) + (output-byte segment (logior byte operand))) + ((<= operand 254) + (output-byte segment (logior byte 15)) + (output-byte segment operand)) + (t + (output-byte segment (logior byte 15)) + (output-byte segment #xff) + (output-byte segment (ldb (byte 8 24) operand)) + (output-byte segment (ldb (byte 8 16) operand)) + (output-byte segment (ldb (byte 8 8) operand)) + (output-byte segment (ldb (byte 8 0) operand)))) + (undefined-value)) + +;;; OUTPUT-LABEL -- internal. +;;; +(defun output-label (segment label) + (declare (type new-assem:segment segment) + (type new-assem:label label)) + (new-assem:assemble (segment) + (new-assem:emit-label label))) + +;;; OUTPUT-REFERENCE -- internal. +;;; +;;; Output a reference to LABEL. If RELATIVE is NIL, then this reference +;;; can never be relative. +;;; +(defun output-reference (segment label) + (declare (type new-assem:segment segment) + (type new-assem:label label)) + (new-assem:emit-back-patch + segment + 3 + #'(lambda (segment posn) + (declare (type new-assem:segment segment) + (ignore posn)) + (let ((target (new-assem:label-position label))) + (assert (<= 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-BRANCH -- internal. +;;; +;;; Output some branch byte-sequence. +;;; +(defun output-branch (segment kind label) + (declare (type new-assem:segment segment) + (type (unsigned-byte 8) kind) + (type new-assem:label label)) + (new-assem:emit-chooser + segment 4 1 + #'(lambda (segment posn delta) + (when (<= (- (ash 1 7)) + (- (new-assem:label-position label posn delta) posn 2) + (1- (ash 1 7))) + (new-assem:emit-chooser + segment 2 1 + #'(lambda (segment posn delta) + (declare (ignore segment) (type index posn delta)) + (when (zerop (- (new-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 we fit in one byte. + (declare (type new-assem:segment segment) + (type index posn)) + (output-byte segment (logior kind 1)) + (output-byte segment + (ldb (byte 8 0) + (- (new-assem:label-position label) posn 2))))) + t)) + #'(lambda (segment posn) + (declare (type new-assem:segment segment) + (ignore posn)) + (let ((target (new-assem:label-position label))) + (assert (<= 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)))))) + +;;; BYTE-OUTPUT-LENGTH -- internal interface. +;;; +;;; Called by the dumping stuff to find out exactly how much noise it needs +;;; to dump. +;;; +(defun byte-output-length (segment) + (declare (type new-assem:segment segment)) + (new-assem:finalize-segment segment)) + + + +;;;; System constants, Xops, and inline functions. + +(defvar *system-constants* (make-array 256)) + +(eval-when (compile eval) + (defmacro def-system-constant (index form) + `(setf (svref *system-constants* ,index) + ,form))) + +(def-system-constant 0 nil) +(def-system-constant 1 t) + + +(defparameter *xop-names* + '(breakpoint + dup + make-closure + merge-unknown-values + default-unknown-values + throw + catch + breakup + return-from + tagbody + go + unwind-protect + fdefn-function-or-lose)) + +(defun xop-index-or-lose (name) + (or (position name *xop-names* :test #'eq) + (error "Unknown XOP ~S" name))) + + +(defstruct inline-function-info + function + number + type) + +(defparameter *inline-functions* + (let ((number -1)) + (mapcar #'(lambda (stuff) + (destructuring-bind (name arg-types result-type) stuff + (make-inline-function-info + :function name + :number (incf number) + :type (specifier-type + `(function ,arg-types ,result-type))))) + '((+ (fixnum fixnum) fixnum) + (- (fixnum fixnum) fixnum) + (make-value-cell (t) t) + (value-cell-ref (t) t) + (value-cell-setf (t t) t) + (symbol-value (symbol) t) + (setf-symbol-value (t symbol) t) + (%byte-special-bind (t symbol) (values)) + (%byte-special-unbind () (values)) + (cons-unique-tag () t))))) + +(defun inline-function-number-or-lose (function) + (let ((info (find function *inline-functions* + :key #'inline-function-info-function))) + (if info + (inline-function-info-number info) + (error "Unknown inline function: ~S" function)))) + + + +;;;; Annotations hung off the IR1 while compiling. + + +(defstruct byte-component-info + (constants (make-array 10 :adjustable t :fill-pointer 0))) + + +(defstruct byte-lambda-info + (label nil :type (or null label)) + (stack-size 0 :type index) + (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 + (argp nil :type (member t nil)) + (offset 0 :type index)) + +(defstruct byte-nlx-info + (stack-slot nil :type (or null index)) + (label (new-assem:gen-label) :type new-assem:label) + (duplicate nil :type (member t nil))) + +(defstruct (byte-block-info + (:include block-annotation) + (:print-function %print-byte-block-info) + (:constructor make-byte-block-info + (block &key produces produces-sset consumes + total-consumes nlx-entries nlx-entry-p))) + (label (new-assem:gen-label) :type new-assem:label) + ;; + ;; A list of the continuations that this block pushes onto the stack. + (produces nil :type list) + ;; + ;; An SSET of the produces for faster set manipulations. + (produces-sset (make-sset) :type sset) + ;; + ;; A list of the continuations that this block pops from the stack. + (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 on the stack (in order) when this block starts. + (start-stack :unknown :type (or (member :unknown) list)) + ;; + ;; The continuations on the stack (in order) when this block ends. + (end-stack nil :type list) + ;; + ;; List of (nlx-infos . extra-stack-cruft) for each entry point in this + ;; block. + (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) + (:print-function %print-byte-continuation-info) + (:constructor make-byte-continuation-info (continuation results))) + (continuation (required-argument) :type continuation) + (results (required-argument) + :type (or (member :fdefinition :eq-test :unknown) unsigned-byte))) + +(defprinter byte-continuation-info + continuation + results) + + + +;;;; Annotate the IR1 + +(defun annotate-continuation (cont results) + ;; 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 + (assert (null (continuation-info cont))) + (setf (continuation-info cont) + (make-byte-continuation-info cont results)) + (undefined-value)) + +(defun annotate-set (set) + ;; Annotate the value for one value. + (annotate-continuation (set-value set) 1)) + +(defun annotate-basic-combination-args (call) + (declare (type basic-combination call)) + (etypecase call + (combination + (dolist (arg (combination-args call)) + (when arg + (annotate-continuation arg 1)))) + (mv-combination + ;; Annoate the args. 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. + (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))))) + (undefined-value)) + +(defun annotate-local-call (call) + (annotate-basic-combination-args call) + (annotate-continuation (basic-combination-fun call) 0)) + +(defun annotate-full-call (call) + (let* ((fun (basic-combination-fun call)) + (name (continuation-function-name fun)) + (info (find name *inline-functions* + :key #'inline-function-info-function))) + (cond ((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)) + ((and (mv-combination-p call) (eq name '%throw)) + (let ((args (basic-combination-args call))) + (assert (= (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-basic-combination-args call) + (annotate-continuation + fun + (let ((use (continuation-use fun))) + (if (ref-p use) + (let ((leaf (ref-leaf use))) + (if (and (global-var-p leaf) + (eq (global-var-kind leaf) :global-function)) + :fdefinition + 1)) + 1)))))) + (undefined-value)) + +(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)) + (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))))) + + ;; 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))))) + (undefined-value)) + +(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)))) + (undefined-value)) + +(defun annotate-ir1 (component) + (do-blocks (block component) + (when (block-interesting block) + (annotate-block block))) + (undefined-value)) + + + +;;;; Stack analysis. + +(defun compute-produces-and-consumes (block) + (let ((stack nil) + (consumes nil) + (total-consumes (make-sset)) + (nlx-entries nil) + (nlx-entry-p nil) + (counter 0)) + (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 (interesting cont))) + (stack + (assert (eq (car stack) cont)) + (pop stack)) + (t + (let ((info (continuation-info cont))) + (unless (byte-continuation-info-number info) + (setf (byte-continuation-info-number info) + (incf counter))) + (sset-adjoin info total-consumes)) + (push cont consumes))))) + (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)) + (when (eq (continuation-function-name + (basic-combination-fun node)) + '%nlx-entry) + (let ((nlx-info (continuation-value + (first (basic-combination-args node))))) + (when (eq (cleanup-kind (nlx-info-cleanup nlx-info)) :block) + (push (nlx-info-continuation nlx-info) stack))) + (setf nlx-entry-p t))) + (cif + (consume (if-test node))) + (creturn + (consume (return-result node))) + (entry + (let ((nlx-info (cleanup-nlx-info (entry-cleanup node)))) + (when nlx-info + (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 ((result (make-sset))) + (dolist (product stack) + (sset-adjoin (continuation-info product) + result)) + result) + :consumes (reverse consumes) + :total-consumes total-consumes + :nlx-entries nlx-entries + :nlx-entry-p nlx-entry-p))) + (undefined-value)) + +(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))))) + +(defun walk-nlx-entry (nlx-infos stack produce consume) + (dolist (cont consume) + (assert (eq (car stack) cont)) + (pop stack)) + (setf stack (append produce stack)) + (dolist (nlx-info nlx-infos) + (walk-block (nlx-info-target nlx-info) nil stack))) + +(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)) + (info (continuation-info cont))) + (when (sset-member info live) + (return)) + (pop stack) + (let ((results (byte-continuation-info-results info))) + (case results + (:unknown + (flush-fixed) + (pops `(%byte-pop-stack 0))) + (:fdefinition + (incf fixed)) + (t + (incf fixed results)))))) + (flush-fixed))) + (when (pops) + (assert 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. + (dolist (cont (byte-block-info-consumes info)) + (assert (eq (car stack) cont)) + (pop stack)) + ;; 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. + (assert (equal (byte-block-info-start-stack info) stack))))) + (undefined-value)) + +(defun byte-stack-analyze (component) + (let ((head nil)) + (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) + (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)) + (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) + (byte-block-info-produces-sset succ-info)) + (setf did-anything t))))) + (when did-anything + (maybe-enqueue-predecessors block))))))) + (walk-successors (component-head component) nil) + (undefined-value)) + + + +;;;; Actually generate the byte-code + +(defvar *byte-component-info*) + +(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 new-assem:segment segment) + (type (integer #.(- (ash 1 32)) #.(1- (ash 1 32))))) + (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 new-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 32)) const (ash 1 32))) + ;; It can be represented as an immediate. + (output-push-int segment const) + ;; We need to store it in the constants pool. + (let* ((posn (position const *system-constants*)) + (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 32)) value (ash 1 32))) + (output-push-int segment value) + (output-push-constant-leaf segment (find-constant value)))) + +(defun output-push-load-time-constant (segment kind datum) + (let* ((constants (byte-component-info-constants *byte-component-info*)) + (index (or (position-if #'(lambda (x) + (and (consp x) + (eq (car x) kind) + (eq (cdr x) datum))) + constants) + (vector-push-extend (cons kind datum) constants)))) + (output-byte-with-operand segment byte-push-constant index)) + (undefined-value)) + +(defun output-do-inline-function (segment function) + ;; Note: we don't annotate this as a call site, because it is used for + ;; internal stuff. Random 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 output-ref-lambda-var (segment var env + &optional (indirect-value-cells t)) + (declare (type new-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 + (position var (environment-closure 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 + (position info (environment-closure env))))) + +(defun output-set-lambda-var (segment var env &optional make-value-cells) + (declare (type new-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 guys 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)) + (output-byte-with-operand segment byte-push-arg + (position var (environment-closure 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))) + (assert (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))))))) + +;;; CANONICALIZE-VALUES -- internal. +;;; +;;; 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 new-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)))) + (undefined-value)) + +(defun generate-byte-code-for-bind (segment bind cont) + (declare (type new-assem:segment segment) (type bind bind) + (ignore cont)) + (let ((lambda (bind-lambda bind)) + (env (node-environment bind))) + (ecase (lambda-kind lambda) + ((nil :top-level :escape :cleanup :optional) + (let* ((info (lambda-info lambda)) + (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)))) + (loop + for argnum upfrom 0 + for var in (lambda-vars lambda) + for info = (lambda-var-info var) + do (unless (or (null info) (byte-lambda-var-info-argp info)) + (output-byte-with-operand segment byte-push-arg argnum) + (output-set-lambda-var segment var env t))))) + ((:let :mv-let :assignment) + ;; Everything has been taken care of in the combination node. + ))) + (undefined-value)) + +(defun generate-byte-code-for-ref (segment ref cont) + (declare (type new-assem:segment segment) (type ref ref) + (type continuation cont)) + (let ((values (byte-continuation-info-results (continuation-info cont))) + (leaf (ref-leaf ref))) + (cond + ((eq values :fdefinition) + (assert (and (global-var-p leaf) + (eq (global-var-kind leaf) + :global-function))) + (output-push-load-time-constant segment + :fdefinition + (global-var-name leaf))) + ((eql values 0) + ;; Real easy! + nil) + (t + (etypecase leaf + (constant + (output-push-constant-leaf segment leaf)) + (clambda + (let* ((refered-env (lambda-environment leaf)) + (closure (environment-closure refered-env))) + (if (null closure) + (output-push-load-time-constant segment :entry leaf) + (let ((my-env (node-environment ref))) + (output-push-load-time-constant segment :xep 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-load-time-constant segment + :fdefinition + (global-var-name leaf)) + (output-do-xop segment 'fdefn-function-or-lose))))) + (canonicalize-values segment values 1)))) + (undefined-value)) + +(defun generate-byte-code-for-set (segment set cont) + (declare (type new-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 + (output-set-lambda-var segment leaf (node-environment set)))) + (unless (eql values 0) + (canonicalize-values segment values 1))) + (undefined-value)) + +(defun generate-byte-code-for-local-call (segment call cont num-args) + (let* ((lambda (combination-lambda call)) + (env (lambda-environment lambda))) + (ecase (functional-kind lambda) + ((:let :mv-let :assignment) + (let ((vars (lambda-vars lambda))) + (dolist (var (reverse vars)) + (when (lambda-var-refs var) + (output-set-lambda-var segment var env t))))) + ((nil :optional :cleanup) + ;; We got us a local call. + (assert (not (eq num-args :unknown))) + ;; First 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)))) + ;; ### :call-site + (output-byte segment + (logior (cond ((node-tail-p call) + byte-local-tail-call) + ((member results '(0 1)) + byte-local-call) + (t + byte-local-multiple-call)) + operand))) + ;; Emit a reference to the label. + (output-reference segment + (byte-lambda-info-label (lambda-info lambda))) + ;; ### :unknown-return + ;; Fix up the results. + (case results + ((:unknown 1) + ;; Don't need to do anything. + ) + (0 + ;; Get rid of the one value. + (output-byte-with-operand segment byte-pop-n 1)) + (t + ;; Something strange. + (canonicalize-values segment results :unknown))))))) + (undefined-value)) + +(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. + (assert (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))))) + (canonicalize-values segment desired-args num-args) + ;; ### :call-site + (output-byte segment (logior byte-inline-function + (inline-function-info-number info))) + ;; ### :known-return + (canonicalize-values segment results 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 + (if (node-tail-p call) + (output-byte segment (logior byte-tail-call operand)) + (case results + (:unknown + (output-byte segment (logior byte-multiple-call operand)) + ;; ### :unknown-return + ) + (0 + (output-byte segment (logior byte-call operand)) + ;; ### :unknown-return + (output-byte-with-operand segment byte-pop-n 1)) + (1 + (output-byte segment (logior byte-call operand)) + ;; ### :unknown-return + ) + (t + (output-byte segment (logior byte-multiple-call operand)) + ;; ### :unknown-return + (canonicalize-values segment results :unknown))))))))) + +(defun generate-byte-code-for-known-call (segment call cont num-args) + (block nil + (catch 'give-up + (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)) + (assert (member (byte-continuation-info-results + (continuation-info + (basic-combination-fun call))) + '(1 :fdefinition))) + (generate-byte-code-for-full-call segment call cont num-args)) + (undefined-value)) + +(defun generate-byte-code-for-generic-combination (segment call cont) + (declare (type new-assem:segment segment) (type basic-combination call) + (type continuation cont)) + (let ((num-args + (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) + ((null (car args)) + ;; This arg has been deleted. Ignore it. + (examine (cdr args) 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))))))))) + (examine (basic-combination-args call) 0)))) + (case (basic-combination-kind call) + (: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) + (canonicalize-values segment + (byte-continuation-info-results + (continuation-info cont)) + 0)) + (t + (generate-byte-code-for-generic-combination segment call cont)))) + +(defun generate-byte-code-for-if (segment if cont) + (declare (type new-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 new-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))) + (undefined-value)) + +(defun generate-byte-code-for-entry (segment entry cont) + (declare (type new-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-do-inline-function segment 'cons-unique-tag) + ;; 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)))))) + (undefined-value)) + +(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 + (position nlx-info + (environment-closure + (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))) + (unless (or (cdr succ) + (eq (byte-block-info-block next) first-succ) + (eq (component-tail component) first-succ)) + (output-branch segment + byte-branch-always + (byte-block-info-label + (block-info first-succ)))))))) + (undefined-value)) + + +;;;; 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. + (assert (eq results :eq-test)) + (assert (eql num-args 2)) + (undefined-value)) + + +(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) + (assert (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) + (assert (eql num-args 0)) + (output-byte-with-operand segment byte-pop-n (continuation-value count)) + (canonicalize-values segment results 0)) + + +(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) + (assert (eql num-args 1)) + (output-push-constant segment (leaf-name (continuation-value var))) + (output-do-inline-function segment '%byte-special-bind) + (canonicalize-values segment results 0)) + +(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) + (assert (eql num-args 0)) + (output-do-inline-function segment '%byte-special-unbind) + (canonicalize-values segment results 0)) + +(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 + (assert (= num-args 1)) + (output-do-xop segment 'catch) + (let ((info (nlx-info-info (continuation-value nlx-info)))) + (output-reference segment (byte-nlx-info-label info))) + (canonicalize-values segment results 0)) + +(defoptimizer (%cleanup-point byte-compile) (() node results num-args segment) + (progn node) ; ignore + (assert (eql num-args 0)) + (canonicalize-values segment results 0)) + + +(defoptimizer (%catch-breakup byte-compile) (() node results num-args segment) + (progn node) ; ignore + (assert (eql num-args 0)) + (output-do-xop segment 'breakup) + (canonicalize-values segment results 0)) + + +(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) + (assert (eql num-args 0)) + (let ((nlx-info (continuation-value nlx-info))) + (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) + (:catch t) + (: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) + (canonicalize-values segment results 0)))) + + +(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 + (assert (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) + (canonicalize-values segment + (byte-continuation-info-results + (continuation-info + (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) + (assert (eql num-args 0)) + (output-do-xop segment 'unwind-protect) + (output-reference segment + (byte-nlx-info-label + (nlx-info-info + (continuation-value nlx-info)))) + (canonicalize-values segment results 0)) + +(defoptimizer (%unwind-protect-breakup byte-compile) + (() node results num-args segment) + (progn node) ; ignore + (assert (eql num-args 0)) + (output-do-xop segment 'breakup) + (canonicalize-values segment results 0)) + +(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 + (assert (member results '(0 nil))) + (assert (eql num-args 0)) + (output-do-xop segment 'breakup)) + + +;;;; XEP descriptions. + +(defstruct (byte-xep + (:print-function %print-byte-xep)) + ;; + ;; The component that this XEP is an entry point into. NIL until + ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. We also allow + ;; cons so that the dumper can stick in a unique cons cell to + ;; identify what component it is trying to dump. What a hack. + (component nil :type (or null kernel:code-component cons)) + ;; + ;; 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 keyword arguments. Each element is a list of: + ;; key, default, supplied-p. + (keywords nil :type list)) + +(defprinter byte-xep) + + +;;; MAKE-XEP-FOR -- internal +;;; +;;; Make a byte-xep for LAMBDA. +;;; +(defun make-xep-for (lambda) + (flet ((entry-point-for (entry) + (let ((info (lambda-info entry))) + (assert (byte-lambda-info-interesting info)) + (new-assem:label-position (byte-lambda-info-label info))))) + (let ((entry (lambda-entry-function lambda))) + (etypecase entry + (optional-dispatch + (let ((rest-arg-p nil)) + (collect ((keywords)) + (dolist (var (nthcdr (optional-dispatch-max-args entry) + (optional-dispatch-arglist entry))) + (let ((arg-info (lambda-var-arg-info var))) + (assert arg-info) + (ecase (arg-info-kind arg-info) + (:rest + (assert (not rest-arg-p)) + (setf rest-arg-p t)) + (:keyword + (keywords (list (arg-info-keyword arg-info) + (arg-info-default arg-info) + (if (arg-info-supplied-p arg-info) t))))))) + (make-byte-xep + :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)) + :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-byte-xep + :min-args args + :max-args args + :entry-points (list (entry-point-for entry))))))))) + +(defun generate-xeps (component) + (let ((xeps nil)) + (dolist (lambda (component-lambdas component)) + (when (member (lambda-kind lambda) '(:external :top-level)) + (push (cons lambda (make-xep-for lambda)) xeps))) + xeps)) + + + +;;;; Noise to actually do the compile. + +(defun assign-locals (component) + ;; + ;; Process all of the lambdas in component, and assign stack frame + ;; locations for all the locals. + (dolist (lambda (component-lambdas component)) + ;; We don't generate any code for :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) + (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)))))) + + (undefined-value)) + + +;;; BYTE-COMPILE-COMPONENT -- internal interface. +;;; +(defun byte-compile-component (component) + (setf (component-info component) (make-byte-component-info)) + + ;; 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) + + ;; 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)))) + + (let ((segment nil)) + (unwind-protect + (progn + (setf segment (new-assem:make-segment :name "Byte Output")) + (generate-byte-code segment component) + (let ((xeps (generate-xeps component)) + (constants (byte-component-info-constants + (component-info component)))) + (when *compiler-trace-output* + (describe-component component *compiler-trace-output*)) + (etypecase *compile-object* + (fasl-file + (maybe-mumble "FASL") + (fasl-dump-byte-component segment constants xeps + *compile-object*)) + (core-object + (maybe-mumble "Core") + (make-core-byte-component segment constants xeps + *compile-object*)) + (null)))) + (when segment + (new-assem:release-segment segment)))) + (undefined-value)) + + + +;;;; Extra stuff for debugging. + +(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~%"))))))) + + + +;;;; Hacks until we want to recompile everything. + +#+nil +(defun block-label (block) + (declare (type cblock block)) + (let ((info (block-info block))) + (etypecase info + (ir2-block + (or (ir2-block-%label info) + (setf (ir2-block-%label info) (gen-label)))) + (byte-block-info + (byte-block-info-label info))))) -- GitLab