From: Juho Snellman Date: Sat, 13 May 2006 17:20:03 +0000 (+0000) Subject: 0.9.12.13: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3ca73f72116001579bde0f59e5aa1359cc41631e;p=sbcl.git 0.9.12.13: Add a simple compiler from some common toplevel forms directly to fasl bytecode operations, instead of going through the real compiler. Shrinks fasls and speeds up COMPILE-FILE and fasl loading. --- diff --git a/NEWS b/NEWS index c315a2f..fe8ebb5 100644 --- a/NEWS +++ b/NEWS @@ -7,6 +7,8 @@ changes in sbcl-0.9.13 relative to sbcl-0.9.12: TYPEP. * improvement: compilation of most CLOS applications is significantly faster + * optimization: added a limited bytecode compiler for simple toplevel + forms, speeding up compilation and FASL loading changes in sbcl-0.9.12 relative to sbcl-0.9.11: * minor incompatible change: in sbcl-0.9.11 (but not earlier diff --git a/build-order.lisp-expr b/build-order.lisp-expr index f606bc3..9976de7 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -519,6 +519,8 @@ ("src/compiler/debug-dump") ("src/compiler/generic/utils") + ("src/compiler/fopcompile") + ("src/assembly/assemfile") ;; Compiling this file requires the macros SB!ASSEM:EMIT-LABEL and diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3db5059..e93a222 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1028,6 +1028,7 @@ retained, possibly temporariliy, because it might be used internally." "WITH-UNIQUE-NAMES" "MAKE-GENSYM-LIST" "ABOUT-TO-MODIFY-SYMBOL-VALUE" "SYMBOL-SELF-EVALUATING-P" + "SELF-EVALUATING-P" "PRINT-PRETTY-ON-STREAM-P" "ARRAY-READABLY-PRINTABLE-P" "LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P" diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index da1abb0..8c0a9f0 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -76,7 +76,7 @@ ;;; versions which break binary compatibility. But it certainly should ;;; be incremented for release versions which break binary ;;; compatibility. -(def!constant +fasl-file-version+ 65) +(def!constant +fasl-file-version+ 66) ;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so) ;;; 38: (2003-01-05) changed names of internal SORT machinery ;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to @@ -135,6 +135,7 @@ ;;; 64: (2006-03-24) New calling convention for unknown-values on x86 and ;;; x86-64. Also (belatedly) PPC/gencgc, including :gencgc on FPAFF. ;;; 65: (2006-04-11) Package locking interface changed. +;;; 66: (2006-05-13) Fopcompiler ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index f09a9c3..8f0d970 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -231,6 +231,11 @@ then else) lexenv))) + ((let let*) + (destructuring-bind (definitions &rest body) (rest exp) + (if (null definitions) + (eval-locally `(locally ,@body) lexenv) + (%eval exp lexenv)))) (t (if (and (symbolp name) (eq (info :function :kind name) :function)) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index c021a01..6179833 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -2,6 +2,12 @@ (in-package "SB!FASL") +;;; 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. +(defvar *skip-until* nil) + ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP ;;; describes what the body does to the fop stack: ;;; T @@ -507,43 +513,53 @@ res))) (define-fop (fop-eval 53) - (let ((result (eval (pop-stack)))) - ;; FIXME: CMU CL had this code here: - ;; (when *load-print* - ;; (load-fresh-line) - ;; (prin1 result) - ;; (terpri)) - ;; Unfortunately, this dependence on the *LOAD-PRINT* global - ;; variable is non-ANSI, so for now we've just punted printing in - ;; fasl loading. - result)) + (if *skip-until* + (pop-stack) + (let ((result (eval (pop-stack)))) + ;; FIXME: CMU CL had this code here: + ;; (when *load-print* + ;; (load-fresh-line) + ;; (prin1 result) + ;; (terpri)) + ;; Unfortunately, this dependence on the *LOAD-PRINT* global + ;; variable is non-ANSI, so for now we've just punted printing in + ;; fasl loading. + result))) (define-fop (fop-eval-for-effect 54 :pushp nil) - (let ((result (eval (pop-stack)))) - ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. - (declare (ignore result)) - #+nil (when *load-print* - (load-fresh-line) - (prin1 result) - (terpri)))) + (if *skip-until* + (pop-stack) + (let ((result (eval (pop-stack)))) + ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. + (declare (ignore result)) + #+nil (when *load-print* + (load-fresh-line) + (prin1 result) + (terpri))))) (define-fop (fop-funcall 55) (let ((arg (read-byte-arg))) - (if (zerop arg) - (funcall (pop-stack)) - (do ((args () (cons (pop-stack) args)) - (n arg (1- n))) - ((zerop n) (apply (pop-stack) args)) - (declare (type index n)))))) + (if *skip-until* + (dotimes (i (1+ arg)) + (pop-stack)) + (if (zerop arg) + (funcall (pop-stack)) + (do ((args () (cons (pop-stack) args)) + (n arg (1- n))) + ((zerop n) (apply (pop-stack) args)) + (declare (type index n))))))) (define-fop (fop-funcall-for-effect 56 :pushp nil) (let ((arg (read-byte-arg))) - (if (zerop arg) - (funcall (pop-stack)) - (do ((args () (cons (pop-stack) args)) - (n arg (1- n))) - ((zerop n) (apply (pop-stack) args)) - (declare (type index n)))))) + (if *skip-until* + (dotimes (i (1+ arg)) + (pop-stack)) + (if (zerop arg) + (funcall (pop-stack)) + (do ((args () (cons (pop-stack) args)) + (n arg (1- n))) + ((zerop n) (apply (pop-stack) args)) + (declare (type index n))))))) ;;;; fops for fixing up circularities @@ -718,3 +734,46 @@ bug.~:@>") (foreign-symbol-address sym t) kind) code-object)) + +;;; 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 (fop-skip 151 :pushp nil) + (let ((position (pop-stack))) + (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 (fop-skip-if-false 152 :pushp nil) + (let ((condition (pop-stack)) + (position (pop-stack))) + (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 (fop-drop-if-skipping 153 :pushp nil) + (when *skip-until* + (pop-stack)) + (values)) + +;;; If skipping, push a dummy value on the stack. Needed for +;;; ensuring that the stack stays balanced when skipping. +(define-fop (fop-push-nil-if-skipping 154 :pushp nil) + (when *skip-until* + (push-stack nil)) + (values)) + +;;; Stop skipping if the top of the stack matches *SKIP-UNTIL* +(define-fop (fop-maybe-stop-skipping 155 :pushp nil) + (let ((label (pop-stack))) + (when (eql *skip-until* label) + (setf *skip-until* nil))) + (values)) diff --git a/src/code/load.lisp b/src/code/load.lisp index b21c7dd..8b3067d 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -174,9 +174,12 @@ (aver (member pushp '(nil t :nope))) (with-unique-names (fop-stack) `(let ((,fop-stack *fop-stack*)) - (declare (type (vector t) ,fop-stack)) + (declare (type (vector t) ,fop-stack) + (ignorable ,fop-stack)) (macrolet ((pop-stack () `(vector-pop ,',fop-stack)) + (push-stack (value) + `(vector-push-extend ,value ,',fop-stack)) (call-with-popped-args (fun n) `(%call-with-popped-args ,fun ,n ,',fop-stack))) ,(if pushp @@ -365,10 +368,11 @@ (defun load-fasl-group (stream) (when (check-fasl-header stream) (catch 'fasl-group-end - (let ((*current-fop-table-index* 0)) + (let ((*current-fop-table-index* 0) + (*skip-until* nil)) + (declare (special *skip-until*)) (loop (let ((byte (read-byte stream))) - ;; Do some debugging output. #!+sb-show (when *show-fops-p* diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index cbf4323..a5d750c 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1241,7 +1241,6 @@ (declare (type component component) (list trace-table)) (declare (type fasl-output file)) - (dump-fop 'fop-verify-empty-stack file) (dump-fop 'fop-verify-table-size file) (dump-word (fasl-output-table-free file) file) @@ -1257,7 +1256,6 @@ fixups file)) (2comp (component-info component))) - (dump-fop 'fop-verify-empty-stack file) (dolist (entry (sb!c::ir2-component-entries 2comp)) (let ((entry-handle (dump-one-entry entry code-handle file))) diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp new file mode 100644 index 0000000..42cff0f --- /dev/null +++ b/src/compiler/fopcompile.lisp @@ -0,0 +1,363 @@ +;;;; 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. +(defun fopcompilable-p (form) + ;; 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. + #+sb-xc-host + nil + #-sb-xc-host + (or (and (self-evaluating-p form) + (constant-fopcompilable-p form)) + (and (symbolp form) + (multiple-value-bind (macroexpansion macroexpanded-p) + (macroexpand form) + (if macroexpanded-p + (fopcompilable-p macroexpansion) + ;; Punt on :ALIEN variables + (let ((kind (info :variable :kind form))) + (or (eq kind :special) + (eq kind :constant)))))) + (and (listp form) + (ignore-errors (list-length form)) + (multiple-value-bind (macroexpansion macroexpanded-p) + (macroexpand 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 (lambda-form-p (car args)) + ;; #'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 variables + ((setq) + (loop for (name value) on args by #'cddr + unless (and (symbolp name) + (let ((kind (info :variable :kind name))) + (eq kind :special)) + (fopcompilable-p value)) + return nil + finally (return t))) + ;; 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 no bindings or + ;; declarations is trivially fopcompilable. Forms + ;; with no bindings but with declarations could also + ;; be handled, but we're currently punting on any + ;; lexenv manipulation. + ((let let*) + (and (>= (length args) 1) + (null (car args)) + (every #'fopcompilable-p (cdr args)))) + ;; Likewise for LOCALLY + ((locally) + (every #'fopcompilable-p (cdr 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)) + ;; We can't FOP-FUNCALL with more than 255 + ;; parameters. (We could theoretically use + ;; APPLY, but then we'd need to construct + ;; the parameter list for APPLY without + ;; calling LIST, which is probably more + ;; trouble than it's worth). + (<= (length args) 255) + (every #'fopcompilable-p args)))))))))) + +(defun lambda-form-p (form) + (and (consp form) + (member (car form) + '(lambda named-lambda instance-lambda lambda-with-lexenv)))) + +;;; Check that a literal form is fopcompilable. It would not for example +;;; when the form contains structures with funny MAKE-LOAD-FORMS. +(defun constant-fopcompilable-p (constant) + (let ((things-processed nil) + (count 0)) + (declare (type (or list hash-table) things-processed) + (type (integer 0 #.(1+ list-to-hash-table-threshold)) count) + (inline member)) + (labels ((grovel (value) + ;; Unless VALUE is an object which which obviously + ;; can't contain other objects + (unless (typep value + '(or unboxed-array + symbol + number + character + string)) + (etypecase things-processed + (list + (when (member value things-processed :test #'eq) + (return-from grovel nil)) + (push value things-processed) + (incf count) + (when (> count list-to-hash-table-threshold) + (let ((things things-processed)) + (setf things-processed + (make-hash-table :test 'eq)) + (dolist (thing things) + (setf (gethash thing things-processed) t))))) + (hash-table + (when (gethash value things-processed) + (return-from grovel nil)) + (setf (gethash value things-processed) t))) + (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 + (multiple-value-bind (creation-form init-form) + (handler-case + (sb!xc:make-load-form value (make-null-lexenv)) + (error (condition) + (compiler-error condition))) + (declare (ignore init-form)) + (case creation-form + (:sb-just-dump-it-normally + (fasl-validate-structure constant *compile-object*) + (dotimes (i (- (%instance-length value) + (layout-n-untagged-slots + (%instance-ref value 0)))) + (grovel (%instance-ref value i)))) + (:ignore-it) + (t + (return-from constant-fopcompilable-p nil))))) + (t + (return-from constant-fopcompilable-p nil)))))) + (grovel constant)) + 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. +(defun fopcompile (form path for-value-p) + (cond ((self-evaluating-p form) + (fopcompile-constant form for-value-p)) + ((symbolp form) + (multiple-value-bind (macroexpansion macroexpanded-p) + (macroexpand form) + (if macroexpanded-p + ;; Symbol macro + (fopcompile macroexpansion path for-value-p) + ;; Special variable + (fopcompile `(symbol-value ',form) path for-value-p)))) + ((listp form) + (multiple-value-bind (macroexpansion macroexpanded-p) + (macroexpand 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 (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 (second form) path for-value-p)) + ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled + ;; by a compiler-macro. Doing general compiler-macro + ;; expansion in the fopcompiler is probably not sensible, + ;; so we'll just special-case it. + ((source-location) + (if (policy *policy* (and (> space 1) + (> space debug))) + (fopcompile-constant nil for-value-p) + (fopcompile (let ((*current-path* path)) + (make-definition-source-location)) + path + for-value-p))) + ((if) + (fopcompile-if args path for-value-p)) + ((progn) + (loop for (arg . next) on args + do (fopcompile arg + path (if next + nil + for-value-p)))) + ((setq) + (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*) + (fopcompile (cons 'progn (cdr args)) path for-value-p)) + ;; Otherwise it must be an ordinary funcall. + (otherwise + (fopcompile-constant operator t) + (dolist (arg args) + (fopcompile arg path t)) + (if for-value-p + (sb!fasl::dump-fop 'sb!fasl::fop-funcall + *compile-object*) + (sb!fasl::dump-fop 'sb!fasl::fop-funcall-for-effect + *compile-object*)) + (let ((n-args (length args))) + ;; stub: FOP-FUNCALL isn't going to be usable + ;; to compile more than this, since its count + ;; is a single byte. Maybe we should just punt + ;; to the ordinary compiler in that case? + (aver (<= n-args 255)) + (sb!fasl::dump-byte n-args *compile-object*)))))))) + (t + (bug "looks unFOPCOMPILEable: ~S" form)))) + +(defun fopcompile-function (form path for-value-p) + (flet ((dump-fdefinition (name) + (fopcompile `(fdefinition ',name) path for-value-p))) + (if (consp form) + (cond + ;; Lambda forms are compiled with the real compiler + ((lambda-form-p form) + ;; We wrap the real lambda inside another one to ensure + ;; that the compiler doesn't e.g. let convert it, thinking + ;; that there are no external references. + (let* ((handle (%compile `(lambda () ,form) + *compile-object* + :path path))) + (when for-value-p + (sb!fasl::dump-push handle *compile-object*) + ;; And then call the wrapper function when loading the FASL + (sb!fasl::dump-fop 'sb!fasl::fop-funcall *compile-object*) + (sb!fasl::dump-byte 0 *compile-object*)))) + ;; While function names are translated to a call to FDEFINITION. + ((legal-fun-name-p form) + (dump-fdefinition form)) + (t + (compiler-error "~S is not a legal function name." form))) + (dump-fdefinition form)))) + +(defun fopcompile-if (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*))) + (sb!fasl::dump-integer else-label *compile-object*) + (fopcompile condition path t) + ;; If condition was false, skip to the ELSE + (sb!fasl::dump-fop 'sb!fasl::fop-skip-if-false *compile-object*) + (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 + (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*)) + ;; Now skip to the END + (sb!fasl::dump-integer end-label *compile-object*) + (sb!fasl::dump-fop 'sb!fasl::fop-skip *compile-object*) + ;; Start of the ELSE branch + (sb!fasl::dump-integer else-label *compile-object*) + (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*) + (fopcompile else path for-value-p) + ;; As before + (when for-value-p + (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*)) + ;; End of IF + (sb!fasl::dump-integer end-label *compile-object*) + (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*) + ;; 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 + (sb!fasl::dump-fop 'sb!fasl::fop-push-nil-if-skipping + *compile-object*))))) + +(defun fopcompile-constant (form for-value-p) + (when for-value-p + (let ((sb!fasl::*dump-only-valid-structures* nil)) + (dump-object form *compile-object*)))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 6ed7cb3..c3afdc7 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -115,6 +115,8 @@ (defvar *compile-object* nil) (declaim (type object *compile-object*)) + +(defvar *fopcompile-label-counter*) ;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES @@ -852,16 +854,19 @@ ;;; *TOPLEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*top-level-form-noted* (note-top-level-form form t)) - (*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* t) - (push tll *toplevel-lambdas*) - (compile-toplevel (list tll) nil)) - nil)) + (if (fopcompilable-p form) + (let ((*fopcompile-label-counter* 0)) + (fopcompile form path nil)) + (let* ((*top-level-form-noted* (note-top-level-form form t)) + (*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* t) + (push tll *toplevel-lambdas*) + (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 diff --git a/version.lisp-expr b/version.lisp-expr index b3c76ae..ce0e226 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.12.12" +"0.9.12.13"