From 3e210f1ce444d6dcffc769719fbdeadc988ff8b0 Mon Sep 17 00:00:00 2001 From: Charles Zhang Date: Tue, 26 Apr 2022 16:11:24 -0700 Subject: [PATCH] Delete fopcompiler and simplify loader substantially. The parent commit added functionality to allow the normal compiler to produce smaller fasls than the fopcompiler in many cases, without a real compile-time or load-time tradeoff. Therefore, remove the fopcompiler, as it adds a lot of complexity and needs to be turned off on high debug or instrumentation. As a bonus, the fopcode space is freed up a bit. It also suffers from multiple macroexpansion. Some things this allows us to simplify: * No need to have LOAD-FORM-IS-DEFAULT-MLFSS-P be used in the compiler. The way we used it was sketchy anyway. * The compiler and loader no longer need to keep track of skipping on the FOP stack, or whether LOAD-TIME-VALUE needs it to be done or not. --- src/code/load.lisp | 69 +--- src/cold/build-order.lisp-expr | 1 - src/cold/exports.lisp | 1 - src/compiler/dce.lisp | 2 +- src/compiler/dump.lisp | 43 +-- src/compiler/fopcompile.lisp | 478 ---------------------------- src/compiler/generic/genesis.lisp | 5 - src/compiler/generic/vm-tran.lisp | 7 +- src/compiler/main.lisp | 50 +-- tests/dump.impure-cload.lisp | 12 +- tests/fopcompiler.impure-cload.lisp | 147 --------- tests/fopcompiler.impure.lisp | 71 ----- tests/fopcompiler.pure.lisp | 25 -- 13 files changed, 41 insertions(+), 870 deletions(-) delete mode 100644 src/compiler/fopcompile.lisp delete mode 100644 tests/fopcompiler.impure-cload.lisp delete mode 100644 tests/fopcompiler.impure.lisp delete mode 100644 tests/fopcompiler.pure.lisp diff --git a/src/code/load.lisp b/src/code/load.lisp index 5e2f9c937..d278cf24b 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -130,11 +130,6 @@ (stack (make-fop-vector 100) :type simple-vector) (name-buffer (vector (make-string 1 :element-type 'character) (make-string 31 :element-type 'base-char))) - ;; Sometimes we want to skip over any FOPs with side-effects (like - ;; function calls) while executing other FOPs. SKIP-UNTIL will - ;; either contain the position where the skipping will stop, or - ;; NIL if we're executing normally. - (skip-until nil :type (or null fixnum)) (print nil :type boolean)) (declaim (freeze-type fasl-input)) @@ -421,8 +416,7 @@ `((macrolet ((fasl-input () '(truly-the fasl-input .fasl-input.)) (fasl-input-stream () '(%fasl-input-stream (fasl-input))) - (operand-stack () '(%fasl-input-stack (fasl-input))) - (skip-until () '(%fasl-input-skip-until (fasl-input)))) + (operand-stack () '(%fasl-input-stack (fasl-input)))) ,@(if (null stack-args) forms (with-unique-names (stack ptr) @@ -1035,24 +1029,19 @@ (read-n-bytes (fasl-input-stream) vector 0 bytes) vector)) -(defun fop-funcall* (argc stack skipping) +(defun fop-funcall* (argc stack) (with-fop-stack ((stack) ptr (1+ argc)) - (unless skipping - (do ((i (+ ptr argc)) - (args)) - ((= i ptr) (apply (fop-stack-ref i) args)) - (declare (type index i)) - (push (fop-stack-ref i) args) - (decf i))))) + (do ((i (+ ptr argc)) + (args)) + ((= i ptr) (apply (fop-stack-ref i) args)) + (declare (type index i)) + (push (fop-stack-ref i) args) + (decf i)))) (define-fop 55 (fop-funcall ((:operands n))) - (fop-funcall* n (operand-stack) (skip-until))) + (fop-funcall* n (operand-stack))) (define-fop 56 (fop-funcall-for-effect ((:operands n)) nil) - (fop-funcall* n (operand-stack) (skip-until))) - -;;; For LOAD-TIME-VALUE which is used for MAKE-LOAD-FORM -(define-fop 57 (fop-funcall-no-skip ((:operands n))) - (fop-funcall* n (operand-stack) nil)) + (fop-funcall* n (operand-stack))) ;;;; fops for fixing up circularities @@ -1218,44 +1207,6 @@ (define-fop 22 (fop-assembler-code) (error "cannot load assembler code except at cold load")) -;;; FOPs needed for implementing an IF operator in a FASL - -;;; Skip until a FOP-MAYBE-STOP-SKIPPING with the same POSITION is -;;; executed. While skipping, we execute most FOPs normally, except -;;; for ones that a) funcall/eval b) start skipping. This needs to -;;; be done to ensure that the fop table gets populated correctly -;;; regardless of the execution path. -(define-fop 6 (fop-skip ((:operands position)) nil) - (unless (skip-until) - (setf (skip-until) position)) - (values)) - -;;; As before, but only start skipping if the top of the FOP stack is NIL. -(define-fop 7 (fop-skip-if-false ((:operands position) condition) nil) - (unless (or condition (skip-until)) - (setf (skip-until) position)) - (values)) - -;;; If skipping, pop the top of the stack and discard it. Needed for -;;; ensuring that the stack stays balanced when skipping. -(define-fop 8 (fop-drop-if-skipping () nil) - (when (skip-until) - (fop-stack-pop-n (operand-stack) 1)) - (values)) - -;;; If skipping, push a dummy value on the stack. Needed for -;;; ensuring that the stack stays balanced when skipping. -(define-fop 9 (fop-push-nil-if-skipping () nil) - (when (skip-until) - (push-fop-stack nil (fasl-input))) - (values)) - -;;; Stop skipping if the top of the stack matches SKIP-UNTIL -(define-fop 10 (fop-maybe-stop-skipping ((:operands label)) nil) - (when (eql (skip-until) label) - (setf (skip-until) nil)) - (values)) - ;;;; fops for code coverage (define-fop 120 :not-host (fop-record-code-coverage (namestring cc) nil) diff --git a/src/cold/build-order.lisp-expr b/src/cold/build-order.lisp-expr index 42e3cb975..a52dbeb80 100644 --- a/src/cold/build-order.lisp-expr +++ b/src/cold/build-order.lisp-expr @@ -470,7 +470,6 @@ #+sb-dyncount ("src/compiler/dyncount") #+sb-dyncount ("src/code/dyncount") - ("src/compiler/fopcompile" :not-host) ("src/code/format-time" :not-host) diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index 90d299dcc..cdae89be7 100644 --- a/src/cold/exports.lisp +++ b/src/cold/exports.lisp @@ -1226,7 +1226,6 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*.") "FASL-OUTPUT-ENTRY-TABLE" "FASL-OUTPUT-STREAM" "FASL-VALIDATE-STRUCTURE" "FASL-NOTE-INSTANCE-SAVES-SLOTS" - "LOAD-FORM-IS-DEFAULT-MLFSS-P" "*!LOAD-TIME-VALUES*" "OPEN-FASL-OUTPUT" "*!COLD-TOPLEVELS*" diff --git a/src/compiler/dce.lisp b/src/compiler/dce.lisp index cbd9e0d04..282ed712a 100644 --- a/src/compiler/dce.lisp +++ b/src/compiler/dce.lisp @@ -9,7 +9,7 @@ ;;; A CLAMBDA is deemed to be "externally referenced" if: ;;; - It is of KIND :TOPLEVEL (a toplevel CLAMBDA). ;;; - It is LAMBDA-HAS-EXTERNAL-REFERENCES-P true (from COMPILE -;;; or from the fopcompiler, possibly other causes). +;;; or possibly other causes). ;;; - It has a REF which has a NODE-COMPONENT other than the ;;; LAMBDA-COMPONENT of the CLAMBDA. ;;; diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 0af2ef3e0..f9e03423a 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -602,16 +602,13 @@ ;;; Emit a funcall of the function and return the handle for the ;;; result. -(defun fasl-dump-load-time-value-lambda (fun file no-skip) +(defun fasl-dump-load-time-value-lambda (fun file) (declare (type sb-c::clambda fun) (type fasl-output file)) (let ((handle (gethash (sb-c::leaf-info fun) (fasl-output-entry-table file)))) (aver handle) (dump-push handle file) - ;; Can't skip MAKE-LOAD-FORM due to later references - (if no-skip - (dump-fop 'fop-funcall-no-skip file 0) - (dump-fop 'fop-funcall file 0))) + (dump-fop 'fop-funcall file 0)) (dump-pop file)) ;;; Return T iff CONSTANT has already been dumped. It's been dumped if @@ -1326,45 +1323,11 @@ ;;;; dumping structures -;;; Even as late as calling DUMP-STRUCTURE we might have to deduce that a -;;; user's "custom" MAKE-LOAD-FORM amounts to MAKE-LOAD-FORM-SAVING-SLOTS -;;; with the default of all slots. Why: suppose you have some structure -;;; (DEFSTRUCT MYSTRUCT A) -;;; and a macro that returns literal instances of the structure: -;;; (DEFMACRO FUNNYMAC (N) (MAKE-MYSTRUCT :A N)) -;;; and a DEFVAR that uses the structure: -;;; (DEFVAR *A* (FUNNYMAC 1)) -;;; -;;; Now, because the fopcompiler expands macros more than once - at least once -;;; in FOPCOMPILABLE-P and then again in FOPCOMPILE - we see _different_ -;;; instances of MYSTRUCT each of those times. We don't memoize the expansion. -;;; The two structures are similar but not EQ, and only the instance produced -;;; during FOPCOMPILABLE-P was entered in the FASL-OUTPUT-VALID-STRUCTURES table. -;;; The other structure instance isn't there, but we need it to be legal to dump. -;;; -;;; This problem is not just theoretical. We ourselves do just that, e.g.: -;;; (defvar *cpus* (... (sb-alien:alien-funcall ...))) -;;; and the expansion of alien-funcall involves an ALIEN-TYPE literal -;;; which gets multiply expanded exactly as described above. -(defun load-form-is-default-mlfss-p (struct) - ;; FIXME? this is called while writing a fasl and so might need - ;; to invoke MAKE-LOAD-FORM, long after IR1 conversion has happened. - ;; Surely this is not the best design. - (and (typep struct 'structure-object) - (multiple-value-bind (creation-form init-form) - (handler-case (make-load-form struct (make-null-lexenv)) - (error (condition) (sb-c:compiler-error condition))) - (multiple-value-bind (ss-creation-form ss-init-form) - (make-load-form-saving-slots struct) - (and (equal creation-form ss-creation-form) - (equal init-form ss-init-form)))))) - (defun dump-structure (struct file) (unless (or (gethash struct (fasl-output-valid-structures file)) (typep struct '(or sb-c::debug-info sb-c::debug-fun sb-c::debug-source - sb-c:definition-source-location sb-c::debug-name-marker)) - (load-form-is-default-mlfss-p struct)) + sb-c:definition-source-location sb-c::debug-name-marker))) (error "attempt to dump invalid structure:~% ~S~%How did this happen?" struct)) (note-potential-circularity struct file) diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp deleted file mode 100644 index f1b9b27fb..000000000 --- a/src/compiler/fopcompile.lisp +++ /dev/null @@ -1,478 +0,0 @@ -;;;; A compiler from simple top-level forms to FASL operations. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-C") - -;;; SBCL has no proper byte compiler (having ditched the rather -;;; ambitious and slightly flaky byte compiler inherited from CMU CL) -;;; but its FOPs are a sort of byte code which is expressive enough -;;; that we can compile some simple toplevel forms directly to them, -;;; including very common operations like the forms that DEFVARs and -;;; DECLAIMs macroexpand into. -;;; -;;; FIXME: The expexnasion problem. -;;; FOPCOMPILE and FOPCOMPILABLE-P cause multiple expansion of macros, -;;; which may be problematic with side-effecting macros. When -;;; FOPCOMPILABLE-P succeeds, FOPCOMPILE is called, resulting in -;;; double macroexpansion. When FOPCOMPILABLE-P fails, -;;; IR1-CONVERT-FUNCTOID expands already expanded macros for a second -;;; time. -;;; And an edge case, when the top-level call has a complier-macro -;;; which returns &whole it gets expanded three times, two times by -;;; FOPCOMPILABLE-P and FOPCOMPILE, and one time by -;;; PROCESS-TOPLEVEL-FORM, because unlike other macros, the expanded -;;; form is still a macro-form. That's what the EXPAND optional -;;; parameter solves, PROCESS-TOPLEVEL-FORM passes NIL, expanding -;;; compiler macros at most once. -;;; The instances of double expansion still remain, e.g. (fun (macro)), -;;; since PROCESS-TOPLEVEL-FORM only expands the macros at the first -;;; position. - -(defun fopcompilable-p (form &optional (expand t)) - ;; We'd like to be able to handle - ;; -- simple funcalls, nested recursively, e.g. - ;; (SET '*PACKAGE* (FIND-PACKAGE "CL-USER")) - ;; -- common self-evaluating forms like strings and keywords and - ;; fixnums, which are important for terminating - ;; the recursion of the simple funcalls above - ;; -- quoted lists (which are important for PROCLAIMs, which are - ;; common toplevel forms) - ;; -- fopcompilable stuff wrapped around non-fopcompilable expressions, - ;; e.g. - ;; (%DEFUN 'FOO (LAMBDA () ...) ...) - ;; -- the IF special form, to support things like (DEFVAR *X* 0) - ;; expanding into (UNLESS (BOUNDP '*X*) (SET '*X* 0)) - ;; - ;; Special forms which we don't currently handle, but might consider - ;; supporting in the future are LOCALLY (with declarations), - ;; MACROLET, SYMBOL-MACROLET and THE. - (flet ((expand (form) - (if expand - (handler-case - (%macroexpand form *lexenv*) - (error () (return-from fopcompilable-p))) - (values form nil))) - (expand-cm (form) - (if expand - (expand-compiler-macro form) - (values form nil)))) - (or (and (self-evaluating-p form) - (constant-fopcompilable-p form)) - (and (symbolp form) - (multiple-value-bind (macroexpansion macroexpanded-p) - (expand form) - (if macroexpanded-p - (fopcompilable-p macroexpansion) - ;; Punt on :ALIEN variables - (let ((kind (info :variable :kind form))) - (member kind '(:special :constant :global :unknown)))))) - (and (listp form) - (ignore-errors (list-length form)) - (let ((macroexpansion (expand-cm form))) - (if (neq macroexpansion form) - (return-from fopcompilable-p (fopcompilable-p macroexpansion)) - t)) - (multiple-value-bind (macroexpansion macroexpanded-p) - (expand form) - (if macroexpanded-p - (fopcompilable-p macroexpansion) - (destructuring-bind (operator &rest args) form - (case operator - ;; Special operators that we know how to cope with - ((progn) - (every #'fopcompilable-p args)) - ((quote) - (and (= (length args) 1) - (constant-fopcompilable-p (car args)))) - ((function) - (and (= (length args) 1) - ;; #'(LAMBDA ...), #'(NAMED-LAMBDA ...), etc. These - ;; are not fopcompileable as such, but we can compile - ;; the lambdas with the real compiler, and the rest - ;; of the expression with the fop-compiler. - (or (and (lambda-form-p (car args)) - ;; The lambda might be closing over some - ;; variable, punt. As a further improvement, - ;; we could analyze the lambda body to - ;; see whether it really closes over any - ;; variables. One place where even simple - ;; analysis would be useful are the PCL - ;; slot-definition type-check-functions - ;; -- JES, 2007-01-13 - (notany (lambda (binding) - (lambda-var-p (cdr binding))) - (lexenv-vars *lexenv*))) - ;; #'FOO, #'(SETF FOO), etc - (legal-fun-name-p (car args))))) - ((if) - (and (<= 2 (length args) 3) - (every #'fopcompilable-p args))) - ;; Allow SETQ only on special or global variables - ((setq) - (loop for (name value) on args by #'cddr - always (and (symbolp name) - (member (info :variable :kind name) - '(:special :global)) - (fopcompilable-p value)))) - ;; The real toplevel form processing has already been - ;; done, so EVAL-WHEN handling will be easy. - ((eval-when) - (and (>= (length args) 1) - (eq (set-difference (car args) - '(:compile-toplevel - compile - :load-toplevel - load - :execute - eval)) - nil) - (every #'fopcompilable-p (cdr args)))) - ;; A LET or LET* that introduces only lexical - ;; bindings might be fopcompilable, depending on - ;; whether something closes over the bindings. - ;; (And whether there are declarations in the body, - ;; see below) - ((let let*) - (let-fopcompilable-p operator args)) - ((locally) - (every #'fopcompilable-p args)) - (otherwise - ;; ordinary function calls - (and (symbolp operator) - ;; If a LET/LOCALLY tries to introduce - ;; declarations, we'll detect it here, and - ;; disallow fopcompilation. This is safe, - ;; since defining a function/macro named - ;; DECLARE would violate a package lock. - (not (eq operator 'declare)) - (not (special-operator-p operator)) - (not (macro-function operator)) ; redundant check - (every #'fopcompilable-p args))))))))))) - -(defun let-fopcompilable-p (operator args) - (when (>= (length args) 1) - (multiple-value-bind (body decls) (parse-body (cdr args) nil) - (declare (ignore body)) - (let* ((orig-lexenv *lexenv*) - (*lexenv* (make-lexenv))) - ;; We need to check for declarations - ;; first. Otherwise the fake lexenv we're - ;; constructing might be invalid. - (and (null decls) - (loop for binding in (car args) - for name = (if (consp binding) - (first binding) - binding) - for value = (if (consp binding) - (second binding) - nil) - ;; Only allow binding locals, since special bindings can't - ;; be easily expressed with fops. - always (and (eq (info :variable :kind name) - :unknown) - (let ((*lexenv* (ecase operator - (let orig-lexenv) - (let* *lexenv*)))) - (fopcompilable-p value))) - do (progn - (setf *lexenv* (make-lexenv)) - (push (cons name - (make-lambda-var :%source-name name)) - (lexenv-vars *lexenv*)))) - (every #'fopcompilable-p (cdr args))))))) - -(defun lambda-form-p (form) - (and (consp form) - (member (car form) - '(lambda named-lambda lambda-with-lexenv)))) - -;;; Check that a literal form is fopcompilable. It would not be, for example, -;;; when the form contains structures with funny MAKE-LOAD-FORMS. -;;; In particular, pathnames are not trivially dumpable because the HOST slot -;;; might need to be dumped as a reference to the *PHYSICAL-HOST* symbol. -;;; This function is nowhere near as OAOO-violating as it once was - it no -;;; longer has local knowledge of the set of leaf types, nor how to test for -;;; non-trivial instances. Sharing more code with MAYBE-EMIT-MAKE-LOAD-FORMS -;;; might be a nice goal, but it seems relatively impossible to achieve. -(defun constant-fopcompilable-p (constant) - (declare (optimize (debug 1))) ;; TCO - (let ((xset (alloc-xset)) - (dumpable-structures)) - (named-let grovel ((value constant)) - ;; Unless VALUE is an object which which obviously - ;; can't contain other objects - (unless (dumpable-leaflike-p value) - (if (xset-member-p value xset) - (return-from grovel nil) - (add-to-xset value xset)) - (typecase value - (cons - (grovel (car value)) - (grovel (cdr value))) - (simple-vector - (dotimes (i (length value)) - (grovel (svref value i)))) - ((vector t) - (dotimes (i (length value)) - (grovel (aref value i)))) - ((simple-array t) - ;; Even though the (ARRAY T) branch does the exact - ;; same thing as this branch we do this separately - ;; so that the compiler can use faster versions of - ;; array-total-size and row-major-aref. - (dotimes (i (array-total-size value)) - (grovel (row-major-aref value i)))) - ((array t) - (dotimes (i (array-total-size value)) - (grovel (row-major-aref value i)))) - (instance - ;; Almost always, a make-load-form method will call - ;; MAKE-LOAD-FORM-SAVING-SLOTS for all slots. If so, - ;; then this structure is amenable to FOPCOMPILE. - ;; If not, then it isn't, which is not strictly true- - ;; the method might have returned a fopcompilable - ;; creation form and no init form. (Handling of - ;; circularity is best left to the main compiler.) - (unless (sb-fasl:load-form-is-default-mlfss-p value) - (return-from constant-fopcompilable-p nil)) - (do-instance-tagged-slot (i value) - (grovel (%instance-ref value i))) - (push value dumpable-structures)) - (t - (return-from constant-fopcompilable-p nil))))) - (dolist (structure dumpable-structures) - (fasl-validate-structure structure *compile-object*)) - t)) - -;;; FOR-VALUE-P is true if the value will be used (i.e., pushed onto -;;; FOP stack), or NIL if any value will be discarded. FOPCOMPILABLE-P -;;; has already ensured that the form can be fopcompiled. -;;; -;;; See the expansion problem FIXME above fopcompilable-p. -(defun fopcompile (form path for-value-p &optional (expand t)) - (let ((path (or (get-source-path form) (cons form path))) - (fasl *compile-object*)) - (flet ((expand (form) - (if expand - (%macroexpand form *lexenv*) - (values form nil))) - (expand-cm (form) - (if expand - (expand-compiler-macro form) - (values form nil)))) - (cond ((self-evaluating-p form) - (fopcompile-constant fasl form for-value-p)) - ((symbolp form) - (multiple-value-bind (macroexpansion macroexpanded-p) - (expand form) - (if macroexpanded-p - ;; Symbol macro - (fopcompile macroexpansion path for-value-p) - (let ((kind (info :variable :kind form))) - (cond - ((eq :special kind) - ;; Special variable - (fopcompile `(symbol-value ',form) path for-value-p)) - - ((member kind '(:global :constant)) - ;; Global variable or constant. - (fopcompile `(symbol-global-value ',form) path for-value-p)) - (t - ;; Lexical - (let* ((var (cdr (assoc form (lexenv-vars *lexenv*)))) - (handle (and (lambda-var-p var) - (leaf-info var)))) - (cond (handle - (setf (lambda-var-ever-used var) t) - (when for-value-p - (sb-fasl::dump-push handle fasl))) - (t - (unless var - ;; Undefined variable. Signal a warning, and - ;; treat it as a special variable reference, like - ;; the real compiler does -- do not elide even if - ;; the value is unused. - (note-undefined-reference form :variable)) - (fopcompile `(symbol-value ',form) - path - for-value-p)))))))))) - ((listp form) - (let ((macroexpansion (expand-cm form))) - (if (neq macroexpansion form) - ;; could expand into an atom, so start from the top - (return-from fopcompile - (fopcompile macroexpansion path for-value-p)))) - (multiple-value-bind (macroexpansion macroexpanded-p) - (expand form) - (if macroexpanded-p - (fopcompile macroexpansion path for-value-p) - (destructuring-bind (operator &rest args) form - (case operator - ;; The QUOTE special operator is worth handling: very - ;; easy and very common at toplevel. - ((quote) - (fopcompile-constant fasl (second form) for-value-p)) - ;; A FUNCTION needs to be compiled properly, but doesn't - ;; need to prevent the fopcompilation of the whole form. - ;; We just compile it, and emit an instruction for pushing - ;; the function handle on the FOP stack. - ((function) - (fopcompile-function fasl (second form) path for-value-p)) - ;; KLUDGE! SB-C:SOURCE-LOCATION calls are normally handled - ;; by a compiler-macro. But if SPACE > DEBUG we choose not - ;; to record locations, which is strange because the main - ;; compiler does not have similar logic afaict. - ((source-location) - ;; FIXME: since the fopcompiler expands compiler-macros, - ;; this case should probably be killed. It can't execute. - (if (policy *policy* (and (> space 1) - (> space debug))) - (fopcompile-constant fasl nil for-value-p) - (fopcompile (let ((*current-path* path)) - (make-definition-source-location)) - path - for-value-p))) - ((if) - (fopcompile-if fasl args path for-value-p)) - ((progn locally) - (if (and for-value-p (endp args)) - (fopcompile nil path t) - (loop for (arg . next) on args - do (fopcompile arg path - (if next nil for-value-p))))) - ((setq) - (if (and for-value-p (endp args)) - (fopcompile nil path t) - (loop for (name value . next) on args by #'cddr - do (fopcompile `(set ',name ,value) path - (if next nil for-value-p))))) - ((eval-when) - (destructuring-bind (situations &body body) args - (if (or (member :execute situations) - (member 'eval situations)) - (fopcompile (cons 'progn body) path for-value-p) - (fopcompile nil path for-value-p)))) - ((let let*) - (let ((orig-lexenv *lexenv*) - (*lexenv* (make-lexenv :default *lexenv*)) - vars) - (loop for binding in (car args) - for name = (if (consp binding) - (first binding) - binding) - for value = (if (consp binding) - (second binding) - nil) - do - (let ((*lexenv* (if (eql operator 'let) - orig-lexenv - *lexenv*))) - (fopcompile value path t)) - (let* ((obj (sb-fasl::dump-pop fasl)) - (var (make-lambda-var - :%source-name name - :info obj))) - (push var vars) - (setf *lexenv* - (make-lexenv - :vars (list (cons name var)))))) - (fopcompile (cons 'progn (cdr args)) path for-value-p) - (when (and vars - (and *source-info* path)) - (let* ((tlf (source-path-tlf-number path)) - (file-info (source-info-file-info *source-info*)) - (*compiler-error-context* - (make-compiler-error-context - :original-form form - :file-name (file-info-truename file-info) - :initialized t - :file-position - (nth-value 1 (find-source-root tlf *source-info*)) - :original-source-path (source-path-original-source path) - :handled-conditions - (lexenv-handled-conditions *lexenv*)))) - (note-unreferenced-vars vars *policy*))))) - ;; Otherwise it must be an ordinary funcall. - (otherwise - (cond - ;; Special hack: there's already a fop for - ;; find-undeleted-package-or-lose, so use it. - ;; (We could theoretically do the same for - ;; other operations, but I don't see any good - ;; candidates in a quick read-through of - ;; src/code/fop.lisp.) - ((and (eq operator 'find-undeleted-package-or-lose) - (= 1 (length args)) - for-value-p) - (fopcompile (first args) path t) - (dump-fop 'sb-fasl::fop-package fasl)) - (t - (when (eq (info :function :where-from operator) :assumed) - (note-undefined-reference operator :function)) - (fopcompile-constant fasl operator t) - (let ((n 0)) - (dolist (arg args) - (incf n) - (fopcompile arg path t)) - (if for-value-p - (dump-fop 'sb-fasl::fop-funcall fasl n) - (dump-fop 'sb-fasl::fop-funcall-for-effect - fasl n))))))))))) - (t - (bug "looks unFOPCOMPILEable: ~S" form)))))) - -(defun fopcompile-function (fasl form path for-value-p) - (cond ((lambda-form-p form) - ;; Lambda forms are compiled with the real compiler - (let ((handle (%compile form fasl :path path))) - (when for-value-p - (sb-fasl::dump-push handle fasl)))) - ;; While function names are translated to a call to FDEFINITION. - ((legal-fun-name-p form) - (fopcompile `(fdefinition ',form) path for-value-p)) - (t - (compiler-error "~S is not a legal function name." form)))) - -(defun fopcompile-if (fasl args path for-value-p) - (destructuring-bind (condition then &optional else) args - (let ((else-label (incf *fopcompile-label-counter*)) - (end-label (incf *fopcompile-label-counter*))) - (fopcompile condition path t) - ;; If condition was false, skip to the ELSE - (dump-fop 'sb-fasl::fop-skip-if-false fasl else-label) - (fopcompile then path for-value-p) - ;; The THEN branch will have produced a value even if we were - ;; currently skipping to the ELSE branch (or over this whole - ;; IF). This is done to ensure that the stack effects are - ;; balanced properly when dealing with operations that are - ;; executed even when skipping over code. But this particular - ;; value will be bogus, so we drop it. - (when for-value-p - (dump-fop 'sb-fasl::fop-drop-if-skipping fasl)) - ;; Now skip to the END - (dump-fop 'sb-fasl::fop-skip fasl end-label) - ;; Start of the ELSE branch - (dump-fop 'sb-fasl::fop-maybe-stop-skipping fasl else-label) - (fopcompile else path for-value-p) - ;; As before - (when for-value-p - (dump-fop 'sb-fasl::fop-drop-if-skipping fasl)) - ;; End of IF - (dump-fop 'sb-fasl::fop-maybe-stop-skipping fasl end-label) - ;; If we're still skipping, we must've triggered both of the - ;; drop-if-skipping fops. To keep the stack balanced, push a - ;; dummy value if needed. - (when for-value-p - (dump-fop 'sb-fasl::fop-push-nil-if-skipping fasl))))) - -(defun fopcompile-constant (fasl form for-value-p) - (when for-value-p - (dump-object form fasl))) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 986ca5f59..b836745a8 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2611,11 +2611,6 @@ Legal values for OFFSET are -4, -8, -12, ..." (push (pop-stack) *!cold-toplevels*) (error "Can't FOP-FUNCALL-FOR-EFFECT random stuff in cold load"))) -;;; Needed for certain L-T-V lambdas that use the -NO-SKIP variant of funcall. -#-c-headers-only -(setf (svref **fop-funs** (get 'fop-funcall-no-skip 'opcode)) - (svref **fop-funs** (get 'fop-funcall 'opcode))) - (define-cold-fop (fop-named-constant-set (index)) (push (cold-list (cold-intern :named-constant) (pop-stack) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 656ae25c0..e6b27a1d4 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -751,15 +751,14 @@ (logior sb-vm:character-widetag (ash (char-code (lvar-value obj)) sb-vm:n-widetag-bits))) +;;; FIXME: The following should really be done by defining +;;; UNBOUND-MARKER as a primitive object. ;; So that the PCL code walker doesn't observe any use of %PRIMITIVE, ;; MAKE-UNBOUND-MARKER is an ordinary function, not a macro. #-sb-xc-host (defun make-unbound-marker () ; for interpreters (sb-sys:%primitive make-unbound-marker)) -;; Get the main compiler to transform MAKE-UNBOUND-MARKER -;; without the fopcompiler seeing it - the fopcompiler does -;; expand compiler-macros, but not source-transforms - -;; because %PRIMITIVE is not generally fopcompilable. +;; Get the main compiler to transform MAKE-UNBOUND-MARKER. (sb-c:define-source-transform make-unbound-marker () `(sb-sys:%primitive make-unbound-marker)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 33c5145a2..cf161c664 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -68,8 +68,6 @@ (defvar *emit-cfasl* nil) -(defvar *fopcompile-label-counter*) - (declaim (inline code-coverage-records code-coverage-blocks)) ;; Used during compilation to map code paths to the matching ;; instrumentation conses. @@ -1036,8 +1034,6 @@ necessary, since type inference may take arbitrarily long to converge.") ;;;; processing of top level forms -(defvar *fopcompile* nil) - ;;; This is called by top level form processing when we are ready to ;;; actually compile something. If (BLOCK-COMPILE *COMPILATION*) is T, ;;; then we still convert the form, but delay compilation, pushing the result @@ -1053,32 +1049,15 @@ necessary, since type inference may take arbitrarily long to converge.") (return-from convert-and-maybe-compile)) ;; Don't bother to compile simple objects that just sit there. (when (and form (or (symbolp form) (consp form))) - (if (and *fopcompile* - (policy *policy* - ;; FOP-compiled code is harder to debug. - (or (< debug 2) - (> space debug))) - ;; The fopcompiler doesn't play nice with coverage data, - ;; as then top level forms don't get instrumented. - (policy *lexenv* (= store-coverage-data 0)) - (not (eq (block-compile *compilation*) t)) - #+sb-xc-host nil - #-sb-xc-host (fopcompilable-p form t)) - (let ((*fopcompile-label-counter* 0)) - ;; Force any pending lambdas to avoid bad ordering - ;; interaction with fop compilation. - (compile-toplevel-lambdas () t) - #+sb-xc-host (error "unreachable") - #-sb-xc-host (fopcompile form path nil t)) - (let* ((*lexenv* (make-lexenv - :policy *policy* - :handled-conditions *handled-conditions* - :disabled-package-locks *disabled-package-locks*)) - (tll (ir1-toplevel form path nil))) - (if (eq (block-compile *compilation*) t) - (push tll (toplevel-lambdas *compilation*)) - (compile-toplevel (list tll) nil)) - nil)))) + (let* ((*lexenv* (make-lexenv + :policy *policy* + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) + (tll (ir1-toplevel form path nil))) + (if (eq (block-compile *compilation*) t) + (push tll (toplevel-lambdas *compilation*)) + (compile-toplevel (list tll) nil)) + nil))) ;;; Macroexpand FORM in the current environment with an error handler. ;;; We only expand one level, so that we retain all the intervening @@ -1439,12 +1418,11 @@ necessary, since type inference may take arbitrarily long to converge.") ;;; Compile FORM and arrange for it to be called at load-time. Return ;;; the dumper handle and our best guess at the type of the object. -;;; TODO: We could use an IR2 bytecode compiler here to produce -;;; smaller code. Same goes for top level code. -(defun compile-load-time-value (form &optional no-skip) +;;; TODO: We could use a bytecode compiler here to produce smaller +;;; code. Same goes for top level code. +(defun compile-load-time-value (form) (let ((lambda (compile-load-time-stuff form t))) - (values (fasl-dump-load-time-value-lambda lambda *compile-object* - no-skip) + (values (fasl-dump-load-time-value-lambda lambda *compile-object*) (let ((type (leaf-type lambda))) (if (fun-type-p type) (single-value-type (fun-type-returns type)) @@ -1603,7 +1581,7 @@ necessary, since type inference may take arbitrarily long to converge.") (catch constant (fasl-note-handle-for-constant constant - (compile-load-time-value creation-form t) + (compile-load-time-value creation-form) fasl) nil) (compiler-error "circular references in creation form for ~S" diff --git a/tests/dump.impure-cload.lisp b/tests/dump.impure-cload.lisp index d74b262b9..8cdac39bd 100644 --- a/tests/dump.impure-cload.lisp +++ b/tests/dump.impure-cload.lisp @@ -229,6 +229,14 @@ )) ; end EVAL-WHEN +(defun load-form-is-default-mlfss-p (object) + (multiple-value-bind (creation-form init-form) + (make-load-form object) + (multiple-value-bind (ss-creation-form ss-init-form) + (make-load-form-saving-slots object) + (and (equal creation-form ss-creation-form) + (equal init-form ss-init-form))))) + ;; Redefine the MAKE-LOAD-FORM method on FOO. (remove-method #'make-load-form (find-method #'make-load-form nil (list 'foo))) (defvar *foo-save-slots* nil) @@ -241,13 +249,13 @@ (let ((foo (make-foo :x 'x :y 'y))) (flet ((assert-canonical (slots) (let ((*foo-save-slots* slots)) - (assert (sb-fasl:load-form-is-default-mlfss-p foo))))) + (assert (load-form-is-default-mlfss-p foo))))) (assert-canonical :all) (assert-canonical '(x y)) ; specifying all slots explicitly is still canonical (assert-canonical '(y x))) ;; specifying only one slot is not canonical (let ((*foo-save-slots* '(x))) - (assert (not (sb-fasl:load-form-is-default-mlfss-p foo)))))) + (assert (not (load-form-is-default-mlfss-p foo)))))) ;; A huge constant vector. This took 9 seconds to compile (on a MacBook Pro) ;; prior to the optimization for using fops to dump. diff --git a/tests/fopcompiler.impure-cload.lisp b/tests/fopcompiler.impure-cload.lisp deleted file mode 100644 index b3e49cb14..000000000 --- a/tests/fopcompiler.impure-cload.lisp +++ /dev/null @@ -1,147 +0,0 @@ -;;;; tests of the fop compiler - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; While most of SBCL is derived from the CMU CL system, the test -;;;; files (like this one) were written from scratch after the fork -;;;; from CMU CL. -;;;; -;;;; This software is in the public domain and is provided with -;;;; absolutely no warranty. See the COPYING and CREDITS files for -;;;; more information. - -(in-package "CL-USER") - -;; Can't use normal ASSERT, since it is not fopcompilable... -(defun assert* (value) - (unless value - (error "assert failed"))) - -;;; Test that the forms that are supposed to be fopcompilable are, and -;;; the ones that aren't aren't. The body might contain further tests to -;;; ensure that the fopcompiled code works as intended. -(defmacro fopcompile-test (fopcompilable-p &body body) - (assert (eql (sb-c::fopcompilable-p `(progn ,@body)) - fopcompilable-p)) - `(progn ,@body)) - -(fopcompile-test t - (let ((a 1)) - (assert* (eql a 1)))) - -(fopcompile-test t - (let ((a 3)) - (let ((a 4)) - (assert* (eql a 4))))) - -(fopcompile-test t - (let* ((a 5)) - (let* ((a 6)) - (assert* (eql a 6))))) - -(fopcompile-test nil - (let ((a 7)) - (assert* (eql (funcall (lambda () a)) 7)))) - -(fopcompile-test nil - (let* ((a 8)) - (assert* (eql (funcall (lambda () a)) 8)))) - -(fopcompile-test t - (let ((a 8) - (b (lambda () 1))) - nil)) - -(fopcompile-test t - (let* ((a (lambda () 1))) - nil)) - -(fopcompile-test nil - (let* ((a 8) - (b (lambda () 1))) - nil)) - -(fopcompile-test nil - (let* ((a 9) - (b (funcall (lambda () a)))) - (assert* (eql b 9)))) - -(fopcompile-test t - (let ((a 10)) - (let ((a 11) - (b a)) - (assert* (eql b 10))))) - -(fopcompile-test t - (let ((a 12)) - (let* ((a 13) - (b a)) - (assert* (eql b 13))))) - -;;; Ensure that we're passing sensible environments to macros during -;;; fopcompilation. Reported by Samium Gromoff. - -(defmacro bar (vars &environment env) - (assert (equal vars - (mapcar #'car (sb-c::lexenv-vars env))))) - -(symbol-macrolet ((foo 1)) - (let* ((x (bar (foo))) - (y (bar (x foo)))) - (bar (y x foo)))) - -;;; Some tests involving compiler-macros. - -(defvar *cmacro-result* nil) - -(defun baz (x) (declare (ignore x))) - -;; functional foo - a function with a compiler-macro -(defun ffoo (x) (push `(regular-ffoo ,x) *cmacro-result*)) -(define-compiler-macro ffoo (x) - `(push `(cmacro-ffoo ,,x) *cmacro-result*)) - -;; macro foo - a macro with a compiler-macro -(defmacro mfoo (x) `(push `(regular-mfoo ,,x) *cmacro-result*)) -(define-compiler-macro mfoo (x) - `(push `(cmacro-mfoo ,,x) *cmacro-result*)) - -(defun get-s () (declare (special s)) s) - -;; Verify some assumptions that the tests will test what was intended. -(eval-when (:compile-toplevel) - (let ((sb-c::*lexenv* (sb-kernel:make-null-lexenv))) - (assert (sb-c::fopcompilable-p '(baz (ffoo 3)))) - (assert (sb-c::fopcompilable-p '(baz (mfoo 3)))) - ;; The special binding of S makes these forms not fopcompilable. - (assert (not (sb-c::fopcompilable-p - '(ffoo (let ((s 3)) (declare (special s)) (get-s)))))) - (assert (not (sb-c::fopcompilable-p - '(mfoo (let ((s 3)) (declare (special s)) (get-s)))))))) - -;; fopcompilable toplevel form should execute the compiler macro -(ffoo 1) -(mfoo 1) -;; fopcompilable form expands embedded compiler-macro -(baz (ffoo 2)) -(baz (mfoo 2)) -;; not-fopcompilable toplevel form should execute the compiler macro. -;; This was ok if the toplevel call was a function with a compiler-macro, -;; but was not working for a toplevel macro having a compiler-macro. -(ffoo (let ((s 3)) (declare (special s)) (get-s))) -(mfoo (let ((s 3)) (declare (special s)) (get-s))) - -(with-test (:name :compiler-macros-at-toplevel) - ;; Now assert about the macroexpansions that happened. - (assert (equal *cmacro-result* - '((CMACRO-MFOO 3) (CMACRO-FFOO 3) - (CMACRO-MFOO 2) (CMACRO-FFOO 2) - (CMACRO-MFOO 1) (CMACRO-FFOO 1))))) - -(when (eval nil) - (lambda () #.(find-package "CL"))) - -(with-test (:name :skip-load-form) - (assert (eq #.(find-package "CL") - (eval '(find-package "CL"))))) diff --git a/tests/fopcompiler.impure.lisp b/tests/fopcompiler.impure.lisp deleted file mode 100644 index cea42b83c..000000000 --- a/tests/fopcompiler.impure.lisp +++ /dev/null @@ -1,71 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; While most of SBCL is derived from the CMU CL system, the test -;;;; files (like this one) were written from scratch after the fork -;;;; from CMU CL. -;;;; -;;;; This software is in the public domain and is provided with -;;;; absolutely no warranty. See the COPYING and CREDITS files for -;;;; more information. - -;;; These tests don't need to be processed by the compiler before -;;; being executed, in fact mustn't go in "fopcompiler.impure-cload.lisp" -;;; because the call to COMPILE-FILE needs to be wrapped in HANDLER-BIND. - -(defvar *tmp-filename* (scratch-file-name)) - -;; Assert that FORM is handled by the fopcompiler, then compile it. -(defun assert-fopcompilable-and-compile-it (form) - ;; Since FOPCOMPILABLE-P now expands compiler-macros, and the macro for - ;; SOURCE-LOCATION expands to a literal structure, we end up calling - ;; CONSTANT-FOPCOMPILABLE-P which needs *COMPILE-OBJECT* to be bound. - (let ((sb-c::*compile-object* - (sb-fasl::make-fasl-output :stream (make-broadcast-stream))) - (sb-c::*lexenv* (sb-kernel:make-null-lexenv))) - (assert (sb-c::fopcompilable-p form)) - (with-open-file (stream *tmp-filename* - :direction :output :if-exists :supersede) - (prin1 form stream)) - (let (warning) - (handler-bind ((warning - (lambda (c) - (when (null warning) - (setq warning c) - (muffle-warning))))) - (multiple-value-bind (output warningp errorp) - (compile-file *tmp-filename*) - (when output - (delete-file output)) - (if (and (not warningp) (not errorp)) - ;; return muffled warning, which didn't count as a warning - warning)))))) - -;; Ensure we can get a style-warning about undefined functions from FOPCOMPILE. -(with-test (:name :fopcompiler-undefined-warning) - ;; Make sure some wiseacre didn't defconstant *FOO* - (assert (eq (sb-int:info :variable :kind '*foo*) :unknown)) - ;; ... or define the I-DO-NOT-EXIST function. - (assert (eq (sb-int:info :function :where-from 'i-do-not-exist) :assumed)) - (let ((w (assert-fopcompilable-and-compile-it - '(defvar *foo* (i-do-not-exist))))) - (assert (and (typep w 'sb-int:simple-style-warning) - (eql (search "undefined" - (write-to-string w :escape nil)) - 0))))) - -;; Note: This tests fails, but for a bad reason, as opposed to the wrong reason -;; (which was also bad). It used to fail because the name of the variable that it -;; used was completely removed, so it failed with "unknown variable". -;; Nobody noticed because the test got marked as failing when the variable was -;; removed. But now despite addition of a new deprecated variable, it fails -;; because it's *actually* failing, because the thing it tests got broken. -;; Ensure that FOPCOMPILE warns about deprecated variables. -(sb-int:define-deprecated-variable :late "1.1.4.9" *i-am-deprecated*) -(with-test (:name :fopcompiler-deprecated-var-warning - :fails-on :sbcl) - (assert (typep (assert-fopcompilable-and-compile-it - '(defvar *frob* (if *i-am-deprecated* 'yes 'no))) - 'sb-ext:deprecation-condition))) - -(ignore-errors (delete-file *tmp-filename*)) diff --git a/tests/fopcompiler.pure.lisp b/tests/fopcompiler.pure.lisp deleted file mode 100644 index 74ac66aea..000000000 --- a/tests/fopcompiler.pure.lisp +++ /dev/null @@ -1,25 +0,0 @@ -;;; Test from git rev cf65b9804d28c5e6ee2fa53cbac143c2f87f108c -;;; which wasn't fully testing what it purported to, which is that -;;; the fopcompiler signals a warning about undefined variables. -;;; (There is no way to assert that by merely placing it in a cload file) -(defvar *value-passer*) -(defun trythis (x) (setf *value-passer* x)) -(defvar *was-fopcompile-called* nil) -(sb-int:encapsulate 'sb-c::fopcompile 'test - (compile nil '(lambda (realfun &rest args) - (setf *was-fopcompile-called* t) - (apply realfun args)))) -(with-test (:name :fopcompile-undefined-var) - (with-scratch-file (fasl "fasl") - (with-scratch-file (lisp "lisp") - (with-open-file (f lisp :direction :output) - (prin1 '(trythis fopcompile-test-undef-var) f)) - (multiple-value-bind (fasl warningp errorp) - (let ((sb-c::*fopcompile* t)) - (compile-file lisp :output-file fasl)) - (sb-int:unencapsulate 'sb-c::fopcompile 'test) - (assert *was-fopcompile-called*) - (assert (and fasl warningp errorp)))) - (setf (symbol-value 'fopcompile-test-undef-var) 1) - (assert (eql (let ((*value-passer*)) (load fasl) *value-passer*) - 1))))