mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
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.
This commit is contained in:
Charles Zhang
Charles Zhang
parent
d3498a22a3
commit
3e210f1ce4
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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*"
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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")))))
|
||||
|
|
@ -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*))
|
||||
|
|
@ -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))))
|
||||
Loading…
Reference in a new issue