master: Allow the compile-evaluator to evaluate forms directly.
apache--- via Sbcl-commits <[email protected]> Mon, 18 May 2026 11:31:07 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 1f5238fe0b578e2a0ef201e851809c9ac9d3d862 (commit)
from 2720527dfadc6ab004d9e6778ed35743aaa59a76 (commit)
- Log -----------------------------------------------------------------
commit 1f5238fe0b578e2a0ef201e851809c9ac9d3d862
Author: Charles Zhang <[email protected]>
Date: Thu Dec 15 12:09:51 2022 +0100
Allow the compile-evaluator to evaluate forms directly.
This change has the overall effect of having the evaluator properly
separate out top level code from any defined functions. See the new
test :EVAL-TOP-LEVEL-CODE-SEPARATE-COMPONENT and the existing tests
:STRUCTURE-SLOT-VALUE-IN-METHOD-NO-CALLEES and
:STRUCTURE-MISSING-SLOT-VALUE-IN-METHOD-SINGLE-CALLEE. As a bonus,
self call recognition works for COMPILE now. As a side effect,
we (correctly) get more redefinition warnings as well (for example for
WARN during bootstrap), which were missing before for some reason.
In order to achieve this, the following needs to be done:
* COMPILE does not have its own special way of doing ir1 conversion
for lambdas anymore, instead relying on the top level lambda machinery
to separate out the actual compiled code. This gives the correct
semantics for policy and compilation etc. for free without special or
duplicate logic, and removes all the stuff around
HAS-EXTERNAL-REFERENCES-P, which was an idea that was never really
finished. This allows us to extend COMPILE-IN-LEXENV to evaluate forms
directly and hence allow %SIMPLE-EVAL to not have to manually wrap the
lambdas either, so evaluation-via-compilation behaves like top-level
evaluation by the file compiler (of course without file compilation
semantics). LTV processing and fasteval also can just evaluate forms
directly with EVAL-WITH-COMPILE-IN-LEXENV.
* Storing source forms should always be off for PCL generated
functions, revealed by the clos-arena test. This was probably not
detected before because the policy inheritance was subtly wrong.
* Fix some tests to not rely on questionable behavior of how named
COMPILE interacts with global type information. Such behavior should
only work in compile file mode.
* The TL-XEP debug name had nothing to do with the actual TL-XEP
functional kind, which was confusing.
* TIME now counts all lambda conversions. Just ignoring the entry
points produced by COMPILE for the top level lambda didn't make much
sense since all other kinds of entry points get counted. It's there
purely to give a hint to the user how much work the compiler is doing,
not to count anything in the source being compiled.
* Core components need to have patch tables again. The fact that they
are exercised in warm bootstrap now means that we are likely actually
using the load time code stripping functionality not just in theory,
vut in practice as well.
* Add post ir1-toplevel processing smashing of names onto compiled
functions again to get names right. As an added bonus, this allows us
to get recognize self calls working for COMPILE functions.
* core debug source infos never actually used the function slot, and
it's not clear what function to give it when evaluating top level
forms, so delete it.
* Also fix > 3 decade old bug in MAKE-LISP-SOURCE-INFO in which a
plain vector was used when one with a fill pointer was expected. I
guess this code path hadn't been exercised in a long time.
---
contrib/sb-sprof/graph.lisp | 2 +-
src/code/cross-misc.lisp | 4 +
src/code/debug-int.lisp | 3 +-
src/code/eval.lisp | 56 ++-----
src/code/time.lisp | 3 +-
src/code/warm-error.lisp | 1 -
src/cold/exports.lisp | 1 +
src/compiler/debug-dump.lisp | 11 +-
src/compiler/debug.lisp | 3 +-
src/compiler/dfo.lisp | 32 +---
src/compiler/entry.lisp | 61 ++++---
src/compiler/envanal.lisp | 3 +-
src/compiler/generic/core.lisp | 75 ++++++---
src/compiler/ir1tran-lambda.lisp | 6 +-
src/compiler/ir1util.lisp | 4 +-
src/compiler/locall.lisp | 20 +--
src/compiler/ltv.lisp | 18 +-
src/compiler/main.lisp | 50 +++---
src/compiler/node.lisp | 50 +-----
src/compiler/target-main.lisp | 350 ++++++++++++++++++---------------------
src/interpreter/eval.lisp | 13 +-
src/pcl/fngen.lisp | 12 +-
tests/compiler-2.impure.lisp | 22 ++-
tests/compiler-2.pure.lisp | 101 ++++-------
tests/compiler.pure-cload.lisp | 71 +++++++-
tests/slot-value.impure.lisp | 12 +-
tests/time.pure.lisp | 5 +-
xperfecthash63.lisp-expr | 3 +
28 files changed, 466 insertions(+), 526 deletions(-)
diff --git a/contrib/sb-sprof/graph.lisp b/contrib/sb-sprof/graph.lisp
index db8f4afa5..652709b91 100644
--- a/contrib/sb-sprof/graph.lisp
+++ b/contrib/sb-sprof/graph.lisp
@@ -262,7 +262,7 @@
(clean-name (name)
(if (and (consp name)
(member (first name)
- '(sb-c::xep sb-c::tl-xep sb-c::&more-processor
+ '(sb-c::xep sb-c::&more-processor
sb-c::top-level-form
sb-c::&optional-processor)))
(second name)
diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp
index 515df1542..15057e23e 100644
--- a/src/code/cross-misc.lisp
+++ b/src/code/cross-misc.lisp
@@ -402,6 +402,10 @@
`(lambda ,@(cddr lambda))
lambda)))
+(defun sb-c:eval-with-compile-in-lexenv (lambda &rest rest)
+ (declare (ignore rest))
+ (funcall (compile nil lambda)))
+
;;; The compiler calls this with forms in EVAL-WHEN (:COMPILE-TOPLEVEL) situations.
(defun eval-tlf (form index &optional lexenv)
(declare (ignore index lexenv))
diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index c40939870..a0472f39e 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -18,8 +18,7 @@
;; Compilation to memory stores each toplevel form given to %COMPILE.
;; That form can generate multiple functions, and those functions can
;; be in one or more code components. They all point at the same form.
- form
- (function nil :read-only t))
+ form)
;;; FIXME: There are an awful lot of package prefixes in this code.
;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?
diff --git a/src/code/eval.lisp b/src/code/eval.lisp
index 4e91cfad3..51eb7692a 100644
--- a/src/code/eval.lisp
+++ b/src/code/eval.lisp
@@ -13,49 +13,17 @@
(defparameter *eval-calls* 0)
-;;;; Turns EXPR into a lambda-form we can pass to COMPILE. Returns
-;;;; a secondary value of T if we must call the resulting function
-;;;; to evaluate EXPR -- if EXPR is already a lambda form, there's
-;;;; no need.
-(defun make-eval-lambda (expr)
- (let ((lambda (if (typep expr '(cons (eql function) (cons t null)))
- (cadr expr)
- expr)))
- (if (typep lambda '(cons (member lambda named-lambda)))
- (values lambda nil)
- (values `(lambda ()
- ;; why PROGN? So that attempts to eval free declarations
- ;; signal errors rather than return NIL. -- CSR, 2007-05-01
- ;; But only force in a PROGN if it's actually needed to flag
- ;; that situation as an error. Macros can't expand into DECLARE,
- ;; so anything other than DECLARE can be left alone.
- ,(if (and (consp expr) (eq (car expr) 'declare))
- `(progn ,expr)
- expr))
- t))))
-
-;;; FIXME: what does "except in that it can't handle toplevel ..." mean?
-;;; Is there anything wrong with the implementation, or is the comment obsolete?
-;;; general case of EVAL (except in that it can't handle toplevel
-;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
+;;; general case of EVAL: Delegate to #'COMPILE.
(defun %simple-eval (expr lexenv)
- (multiple-value-bind (lambda call) (make-eval-lambda expr)
- (let ((fun
- ;; This tells the compiler where the lambda comes from, in case it
- ;; wants to report any problems.
- (let ((sb-c::*source-form-context-alist*
- (acons lambda *eval-source-context*
- sb-c::*source-form-context-alist*)))
- (handler-bind (;; Compiler notes just clutter up the REPL:
- ;; anyone caring about performance should not
- ;; be using EVAL.
- (compiler-note #'muffle-warning))
- (sb-c:compile-in-lexenv lambda lexenv nil *eval-source-info*
- *eval-tlf-index* nil (not call))))))
- (declare (function fun))
- (if call
- (funcall fun)
- fun))))
+ (let ((sb-c::*source-form-context-alist*
+ (acons expr *eval-source-context*
+ sb-c::*source-form-context-alist*)))
+ (handler-bind (;; Compiler notes just clutter up the REPL:
+ ;; anyone caring about performance should not
+ ;; be using EVAL.
+ (compiler-note #'muffle-warning))
+ (sb-c:eval-with-compile-in-lexenv expr lexenv *eval-source-info*
+ *eval-tlf-index* nil))))
;;; Handle PROGN and implicit PROGN.
#-sb-fasteval
@@ -181,10 +149,6 @@
(if (and (legal-fun-name-p name)
(not (consp (sb-c:lexenv-find name funs :lexenv lexenv))))
(%coerce-name-to-fun name)
- ;; FIXME: This is a bit wasteful: it would be nice to call
- ;; COMPILE-IN-LEXENV with the lambda-form directly, but
- ;; getting consistent source context and muffling compiler notes
- ;; is easier this way.
(%simple-eval original-exp lexenv))))
((quote)
(unless (= n-args 1)
diff --git a/src/code/time.lisp b/src/code/time.lisp
index f6ae6b6f2..2a18d3162 100644
--- a/src/code/time.lisp
+++ b/src/code/time.lisp
@@ -416,7 +416,8 @@ returns values returned by FUNCTION.
Number of calls to EVAL. (Omitted if zero.)
:LAMBDAS-CONVERTED
- Number of lambdas converted. (Omitted if zero.)
+ Number of (potentially compiler introduced) lambdas converted to
+ IR. (Omitted if zero.)
:PAGE-FAULTS
Number of page faults. (Omitted if zero.)
diff --git a/src/code/warm-error.lisp b/src/code/warm-error.lisp
index 4ae437de9..04dd524e8 100644
--- a/src/code/warm-error.lisp
+++ b/src/code/warm-error.lisp
@@ -51,7 +51,6 @@
superclassoid-name condition)))
nil))
- ;; We don't warn about redefinition of WARN, apparently (not sure why)
(defun warn (datum &rest arguments)
"Warn about a situation by signalling a condition formed by DATUM and
ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index 62ca3ca2f..c252c5bc1 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -2682,6 +2682,7 @@ be submitted as a CDR")
"DO-FORMS-FROM-INFO"
"EMIT-BLOCK-HEADER"
"ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN"
+ "EVAL-WITH-COMPILE-IN-LEXENV"
"FAST-SYMBOL-VALUE"
"FAST-SYMBOL-GLOBAL-VALUE"
"FIXUP-NOTE-KIND"
diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index f4ed920e3..6c989f640 100644
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -413,11 +413,11 @@
;;; Return DEBUG-SOURCE structure containing information derived from
;;; INFO.
-(defun debug-source-for-info (info &key function)
+(defun debug-source-for-info (info &key core)
(declare (type source-info info))
(let ((file-info (get-toplevelish-file-info info)))
(multiple-value-call
- (if function 'sb-di::make-core-debug-source 'make-debug-source)
+ (if core 'sb-di::make-core-debug-source 'make-debug-source)
:namestring (or *source-namestring*
(make-file-info-namestring
(let ((pathname
@@ -441,11 +441,10 @@
file-write-date))
:start-positions (coerce-to-smallest-eltype
(file-info-positions file-info))
- (if function
+ (if core
(values :form (let ((direct-file-info (source-info-file-info info)))
(when (eq :lisp (file-info-%truename direct-file-info))
- (elt (file-info-forms direct-file-info) 0)))
- :function function)
+ (elt (file-info-forms direct-file-info) 0))))
(values)))))
(defun smallest-element-type (integer negative)
@@ -768,7 +767,7 @@
(name (leaf-debug-name fun))
(name (if (consp name)
(case (car name)
- ((xep tl-xep)
+ ((xep)
(aver (eql kind :external))
(second name))
(&optional-processor
diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 7eb304c8a..bce087617 100644
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -428,7 +428,8 @@
(let ((leaf (ref-leaf node)))
(when (functional-p leaf)
(if (functional-kind-eq leaf toplevel-xep)
- (unless (component-toplevelish-p (block-component (node-block node)))
+ (unless (eq (component-kind (block-component (node-block node)))
+ :toplevel)
(barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
node))
(check-fun-reached leaf node)))))
diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp
index 54f44d203..ae3a3ffb4 100644
--- a/src/compiler/dfo.lisp
+++ b/src/compiler/dfo.lisp
@@ -14,8 +14,6 @@
;;; An entry point is reachable if:
;;; - Its home lambda is of KIND :TOPLEVEL.
-;;; - Its home lambda is LAMBDA-HAS-EXTERNAL-REFERENCES-P true (from
-;;; COMPILE or possibly other causes).
;;; - Its home lambda is either referenced from a reachable block in
;;; the same component or referenced from a different component.
(defun entry-point-reached-p (ep)
@@ -24,7 +22,6 @@
(if (bind-p start-node)
(let ((fun (bind-lambda start-node)))
(or (functional-kind-eq fun toplevel)
- (lambda-has-external-references-p fun)
(let ((component (block-component ep)))
(some (lambda (ref)
;; The REF could have been deleted, in which
@@ -208,9 +205,8 @@
;;; to XEP lambdas. We can ignore references to XEPs that appear in
;;; :TOPLEVEL components, since environment analysis goes to special
;;; effort to allow closing over of values from a separate top level
-;;; component. (And now that HAS-EXTERNAL-REFERENCES-P-ness
-;;; generalizes :TOPLEVEL-ness, we ignore those too.) All other
-;;; references must cause components to be joined.
+;;; component. All other references must cause components to be
+;;; joined.
;;;
;;; References in deleted functions are also ignored, since this code
;;; will be deleted eventually.
@@ -218,11 +214,8 @@
(collect ((res))
(dolist (ref (leaf-refs fun))
(let* ((home (node-home-lambda ref))
- (home-kind (functional-kind home))
- (home-externally-visible-p
- (or (eql home-kind (functional-kind-attributes toplevel))
- (functional-has-external-references-p home))))
- (unless (or (and home-externally-visible-p
+ (home-kind (functional-kind home)))
+ (unless (or (and (eql home-kind (functional-kind-attributes toplevel))
(functional-kind-eq fun external))
(eql home-kind (functional-kind-attributes deleted)))
(res home))))
@@ -355,21 +348,8 @@
(unless (eq (block-next (component-head component))
(component-tail component))
(let* ((funs (component-lambdas component))
- (has-top (find (functional-kind-attributes toplevel) funs :key #'functional-kind))
- (has-external-references
- (some #'functional-has-external-references-p funs)))
- (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
- ;; is newer than the rest of this function, and
- ;; doesn't really seem to fit into its mindset. Here
- ;; we mark components which contain such FUNCTIONs
- ;; them as :COMPLEX-TOPLEVEL, since they do get
- ;; executed at run time, and since it's not valid to
- ;; delete them just because they don't have any
- ;; references from pure :TOPLEVEL components. -- WHN
- has-external-references
- (setf (component-kind component) :complex-toplevel)
- (non-top component))
- ((or (some #'has-xep-or-nlx funs)
+ (has-top (find (functional-kind-attributes toplevel) funs :key #'functional-kind)))
+ (cond ((or (some #'has-xep-or-nlx funs)
(and has-top (rest funs)))
(setf (component-name component) (find-component-name component))
(non-top component)
diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp
index 7bd6fb2b2..8a905f2f0 100644
--- a/src/compiler/entry.lisp
+++ b/src/compiler/entry.lisp
@@ -108,16 +108,14 @@ missing MAKE-LOAD-FORM methods?")
(values))
;;; Replace all references to COMPONENT's non-closure XEPs that appear
-;;; in top level or externally-referenced components, changing to
-;;; :TOPLEVEL-XEP FUNCTIONALs. If the cross-component ref is not in a
-;;; :TOPLEVEL/externally-referenced component, or is to a closure,
-;;; then substitution is suppressed.
+;;; in top level components, changing to :TOPLEVEL-XEP FUNCTIONALs. If
+;;; the cross-component ref is not in a :TOPLEVEL component, or is to
+;;; a closure, then substitution is suppressed.
;;;
;;; When a cross-component ref is not substituted, we return T to
;;; indicate that early deletion of this component's IR1 should not be
-;;; done. We also return T if this component contains
-;;; :TOPLEVEL/externally-referenced lambdas (though it is not a
-;;; :TOPLEVEL component.)
+;;; done. We also return T if this component contains :TOPLEVEL
+;;; lambdas (though it is not a :TOPLEVEL component.)
;;;
;;; We deliberately don't use the normal reference deletion, since we
;;; don't want to trigger deletion of the XEP (although it shouldn't
@@ -128,31 +126,30 @@ missing MAKE-LOAD-FORM methods?")
(dolist (lambda (component-lambdas component))
(functional-kind-case lambda
(external
- (unless (lambda-has-external-references-p lambda)
- (let* ((ef (functional-entry-fun lambda))
- (new (make-functional
- :kind (functional-kind-attributes toplevel-xep)
- :info (leaf-info lambda)
- :%source-name (functional-%source-name ef)
- :%debug-name (functional-%debug-name ef)
- :lexenv (make-null-lexenv)))
- (main-entry (main-entry ef))
- (closure (and
- ;; It may have been deleted due to none of
- ;; the optional entries reaching it.
- (not (functional-kind-eq main-entry deleted))
- (environment-closure (lambda-environment main-entry)))))
- (dolist (ref (leaf-refs lambda))
- (let ((ref-component (node-component ref)))
- (cond ((eq ref-component component))
- ((or (not (component-toplevelish-p ref-component))
- closure)
- (setq res t))
- (t
- (setf (ref-leaf ref) new)
- (push ref (leaf-refs new))
- (setf (leaf-refs lambda)
- (delq1 ref (leaf-refs lambda))))))))))
+ (let* ((ef (functional-entry-fun lambda))
+ (new (make-functional
+ :kind (functional-kind-attributes toplevel-xep)
+ :info (leaf-info lambda)
+ :%source-name (functional-%source-name ef)
+ :%debug-name (functional-%debug-name ef)
+ :lexenv (make-null-lexenv)))
+ (main-entry (main-entry ef))
+ (closure (and
+ ;; It may have been deleted due to none of
+ ;; the optional entries reaching it.
+ (neq (functional-kind main-entry) :deleted)
+ (environment-closure (lambda-environment main-entry)))))
+ (dolist (ref (leaf-refs lambda))
+ (let ((ref-component (node-component ref)))
+ (cond ((eq ref-component component))
+ ((or (not (eq (component-kind ref-component) :toplevel))
+ closure)
+ (setq res t))
+ (t
+ (setf (ref-leaf ref) new)
+ (push ref (leaf-refs new))
+ (setf (leaf-refs lambda)
+ (delq1 ref (leaf-refs lambda)))))))))
(toplevel
(setq res t))))
res))
diff --git a/src/compiler/envanal.lisp b/src/compiler/envanal.lisp
index 556f21dc5..aafc36e29 100644
--- a/src/compiler/envanal.lisp
+++ b/src/compiler/envanal.lisp
@@ -54,8 +54,7 @@
(dolist (fun (component-lambdas component))
(when (null (leaf-refs fun))
(let ((kind (functional-kind fun)))
- (unless (or (eql kind (functional-kind-attributes toplevel))
- (functional-has-external-references-p fun))
+ (unless (eql kind (functional-kind-attributes toplevel))
(aver (logtest kind (functional-kind-attributes optional cleanup escape)))
(setf (functional-kind fun) (functional-kind-attributes nil))
(delete-functional fun)))))
diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp
index 1c41a4e26..bc21444c5 100644
--- a/src/compiler/generic/core.lisp
+++ b/src/compiler/generic/core.lisp
@@ -22,11 +22,26 @@
;; A hashtable translating ENTRY-INFO structures to the corresponding actual
;; FUNCTIONs for functions in this compilation.
(entry-table (make-hash-table :test 'eq) :type hash-table)
+ ;; A hashtable translating ENTRY-INFO structures to a list of pairs
+ ;; (<code object> . <offset>) describing the places that need to be
+ ;; backpatched to point to the function for ENTRY-INFO.
+ (patch-table (make-hash-table :test 'eq) :type hash-table)
;; A list of all the DEBUG-INFO objects created, kept so that we can
;; backpatch with the source info.
(debug-info () :type list))
+;;; Note the existence of FUNCTION.
+(defun note-fun (info function object)
+ (declare (type function function)
+ (type core-object object))
+ (let ((patch-table (core-object-patch-table object)))
+ (dolist (patch (gethash info patch-table))
+ (setf (code-header-ref (car patch) (the index (cdr patch))) function))
+ (remhash info patch-table))
+ (setf (gethash info (core-object-entry-table object)) function)
+ (values))
+
;;; Map of code-component -> list of PC offsets at which allocations occur.
;;; This table is needed in order to enable allocation profiling.
(define-load-time-global *allocation-patch-points*
@@ -138,6 +153,19 @@
real-code-obj callees))))
(finish-fixups code-obj callees retained-fixups))))
+;;; Stick a reference to the function FUN in CODE-OBJECT at index I. If the
+;;; function hasn't been compiled yet, make a note in the patch table.
+(defun reference-core-fun (code-obj i fun object set-code-header-ref)
+ (declare (type core-object object) (type functional fun)
+ (type index i))
+ (let* ((info (leaf-info fun))
+ (found (gethash info (core-object-entry-table object))))
+ (if found
+ (funcall set-code-header-ref found code-obj i)
+ (push (cons code-obj i)
+ (gethash info (core-object-patch-table object)))))
+ (values))
+
;;; Dump a component to core. We pass in the assembler fixups, code
;;; vector and node info.
(defun make-core-component (component assembly object)
@@ -189,32 +217,39 @@
;; Don't need code pinned now
;; (It will implicitly be pinned on the conservatively scavenged backends)
- (macrolet ((set-boxed-word (i val)
- #+darwin-jit
- `(setf (svref boxed-data (- ,i ,sb-vm:code-constants-offset)) ,val)
- #-darwin-jit
- `(setf (code-header-ref code-obj ,i) ,val)))
-
+ (flet (((setf code-header-ref) (new-val code-obj i)
+ #+darwin-jit
+ (declare (ignore code-obj))
+ #+darwin-jit
+ (setf (svref boxed-data (- i sb-vm:code-constants-offset)) new-val)
+ #-darwin-jit
+ (setf (code-header-ref code-obj i) new-val)))
+ (declare (inline (setf code-header-ref)))
(let* ((entries (ir2-component-entries 2comp))
(fun-index (length entries)))
(dolist (entry-info entries)
(let ((fun (%code-entry-point code-obj (decf fun-index))))
(aver (functionp fun)) ; in case %CODE-ENTRY-POINT returns NIL
- (setf (gethash entry-info (core-object-entry-table object)) fun))))
+ (note-fun entry-info fun object))))
(do ((index const-patch-start-index (1+ index)))
((>= index n-boxed-words))
(let ((const (aref constants index)))
- (set-boxed-word index
- (if (constant-p const)
- (constant-value const)
- (destructuring-bind (kind payload) const
- (ecase kind
- (:fdefinition payload)
- (:entry
- (the function (gethash (leaf-info payload)
- (core-object-entry-table object))))
- (:known-fun (%coerce-name-to-fun payload))))))))
+ (etypecase const
+ (constant
+ (setf (code-header-ref code-obj index)
+ (constant-value const)))
+ (list
+ (destructuring-bind (kind payload) const
+ (ecase kind
+ (:entry
+ (reference-core-fun code-obj index payload object #'(setf code-header-ref)))
+ (:fdefinition
+ (setf (code-header-ref code-obj index)
+ payload))
+ (:known-fun
+ (setf (code-header-ref code-obj index)
+ (%coerce-name-to-fun payload)))))))))
#+darwin-jit (assign-code-constants code-obj boxed-data))
@@ -231,10 +266,10 @@
;;; Backpatch all the DEBUG-INFOs dumped so far with the specified
;;; SOURCE-INFO list. We also check that there are no outstanding
;;; forward references to functions.
-(defun fix-core-source-info (info object &optional function)
+(defun fix-core-source-info (info object &optional store-source)
(declare (type core-object object))
- (declare (type (or null function) function))
- (let ((source (debug-source-for-info info :function function)))
+ (aver (zerop (hash-table-count (core-object-patch-table object))))
+ (let ((source (debug-source-for-info info :core store-source)))
(dolist (info (core-object-debug-info object))
(setf (debug-info-source info) source)))
(setf (core-object-debug-info object) nil)
diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 33fc5a620..df074e72a 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -995,11 +995,7 @@
lambda-list))
(setf (functional-documentation res) doc)
(when (boundp '*lambda-conversions*)
- ;; KLUDGE: Not counting TL-XEPs is a lie, of course, but
- ;; keeps things less confusing to users of TIME, where this
- ;; count gets used.
- (unless (and (consp debug-name) (eq 'tl-xep (car debug-name)))
- (incf *lambda-conversions*)))
+ (incf *lambda-conversions*))
res))
(defun wrap-forms-in-debug-catch (forms)
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index babf5cd3d..425466049 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -2165,7 +2165,6 @@
(let ((original-kind (functional-kind clambda))
(bind (lambda-bind clambda)))
(aver (not (logtest original-kind (functional-kind-attributes deleted toplevel))))
- (aver (not (functional-has-external-references-p clambda)))
(aver (or (eql original-kind (functional-kind-attributes zombie)) bind))
(setf (functional-kind clambda) (functional-kind-attributes deleted))
(setf (lambda-bind clambda) nil)
@@ -2309,8 +2308,7 @@
((nil let mv-let assignment escape cleanup)
(delete-lambda leaf))
(external
- (unless (functional-has-external-references-p leaf)
- (delete-lambda leaf)))
+ (delete-lambda leaf))
((deleted zombie optional))))
(optional-dispatch
(unless (functional-kind-eq leaf deleted)
diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 4de0d91ac..40577692e 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -347,20 +347,16 @@
(component-reanalyze *current-component*) t
(leaf-type xep) (definition-type fun))
(reoptimize-component *current-component* :maybe)
- (locall-analyze-xep-entry-point fun)
+ (etypecase fun
+ (clambda
+ (locall-analyze-fun-1 fun))
+ (optional-dispatch
+ (dolist (ep (optional-dispatch-entry-points fun))
+ (locall-analyze-fun-1 (force ep)))
+ (when (optional-dispatch-more-entry fun)
+ (locall-analyze-fun-1 (optional-dispatch-more-entry fun)))))
xep)))
-(defun locall-analyze-xep-entry-point (fun)
- (declare (type functional fun))
- (etypecase fun
- (clambda
- (locall-analyze-fun-1 fun))
- (optional-dispatch
- (dolist (ep (optional-dispatch-entry-points fun))
- (locall-analyze-fun-1 (force ep)))
- (when (optional-dispatch-more-entry fun)
- (locall-analyze-fun-1 (optional-dispatch-more-entry fun))))))
-
;;; Notice a REF that is not in a local-call context. If the REF is
;;; already to an XEP, then do nothing, otherwise change it to the
;;; XEP, making an XEP if necessary.
diff --git a/src/compiler/ltv.lisp b/src/compiler/ltv.lisp
index 90d78d558..fbdcd709c 100644
--- a/src/compiler/ltv.lisp
+++ b/src/compiler/ltv.lisp
@@ -94,16 +94,14 @@ guaranteed to never be modified, so it can be put in read-only storage."
;; versus do both in the null environment. The distinction is in whether
;; (LET ((X 3)) (MACROLET ((M () (HAIR))) (LOAD-TIME-VALUE (THING)))
;; can make use of M. We choose to say that it can't.
- (let ((value (let ((thunk ; Pass T for the EPHEMERAL flag.
- (compile-in-lexenv `(lambda ()
- (declare (local-optimize (verify-arg-count 0)))
- ,form)
- (make-null-lexenv)
- nil nil nil t nil)))
- (handler-case (funcall thunk)
- (error (condition)
- (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
- condition))))))
+ (let ((value (handler-case
+ ;; Pass T for the EPHEMERAL flag.
+ (eval-with-compile-in-lexenv form
+ (make-null-lexenv)
+ nil nil t)
+ (error (condition)
+ (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
+ condition)))))
(if read-only-p
(ir1-convert start next result `',value)
#+cheneygc
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index aa946e866..54c4920d1 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -302,20 +302,26 @@ Examples:
;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
;;; WARNINGS-P and FAILURE-P are as in CL:COMPILE or CL:COMPILE-FILE.
-(defmacro with-compilation-values (&body body)
- `(let ((*finite-sbs*
- (vector
- ,@(loop for sb across *backend-sbs*
- unless (eq (sb-kind sb) :non-packed)
- collect
- (let ((size (sb-size sb)))
- `(make-finite-sb
- (make-array ,size :initial-element #())
- (make-array ,size :initial-element #*)
- (make-array ,size :initial-element nil)))))))
- (let ((*warnings-p* nil)
- (*failure-p* nil))
- (values (progn ,@body) *warnings-p* *failure-p*))))
+(defmacro with-compilation-values ((&key just-values) &body body)
+ (let ((gensym (gensym)))
+ `(let ((*finite-sbs*
+ (vector
+ ,@(loop for sb across *backend-sbs*
+ unless (eq (sb-kind sb) :non-packed)
+ collect
+ (let ((size (sb-size sb)))
+ `(make-finite-sb
+ (make-array ,size :initial-element #())
+ (make-array ,size :initial-element #*)
+ (make-array ,size :initial-element nil)))))))
+ (let ((*warnings-p* nil)
+ (*failure-p* nil))
+ (flet ((,gensym ()
+ (progn ,@body)))
+ (if ,just-values
+ (,gensym)
+ (values (,gensym)
+ *warnings-p* *failure-p*)))))))
;;; THING is a kind of thing about which we'd like to issue a warning,
;;; but showing at most one warning for a given set of <THING,FMT,ARGS>.
@@ -655,8 +661,6 @@ necessary, since type inference may take arbitrarily long to converge.")
;;; normally causes the components to be combined.
(defun delete-if-no-entries (component)
(dolist (fun (component-lambdas component) (delete-component component))
- (when (functional-has-external-references-p fun)
- (return))
(functional-kind-case fun
(toplevel (return))
(external
@@ -834,11 +838,11 @@ necessary, since type inference may take arbitrarily long to converge.")
;;; Return a SOURCE-INFO to describe the incremental compilation of FORM.
(defun make-lisp-source-info (form &key parent)
- (make-source-info
- :file-info (make-file-info :%truename :lisp
- :forms (vector form)
- :positions '#(0))
- :parent parent))
+ (let ((file-info (make-file-info :%truename :lisp :positions '#(0))))
+ (vector-push-extend form (file-info-forms file-info))
+ (make-source-info
+ :file-info file-info
+ :parent parent)))
;;; Walk up the SOURCE-INFO list until we either reach a SOURCE-INFO
;;; with no parent (e.g., from a REPL evaluation) or until we reach a
@@ -909,7 +913,7 @@ necessary, since type inference may take arbitrarily long to converge.")
;; special case for COMPILE-FORM-TO-FILE
(return-from %do-forms-from-info
(let* ((forms (file-info-forms (source-info-file-info info)))
- (form (shiftf (svref forms 0) nil)))
+ (form (shiftf (aref forms 0) nil)))
(when form
(funcall function form :current-index 0)))))
(let* ((file-info (source-info-file-info info))
@@ -1629,7 +1633,7 @@ necessary, since type inference may take arbitrarily long to converge.")
(sb-impl::*eval-source-context* nil))
(handler-case
(handler-bind (((satisfies handle-condition-p) 'handle-condition-handler))
- (with-compilation-values
+ (with-compilation-values ()
(with-compilation-unit ()
(handler-bind ((compiler-error #'compiler-error-handler)
(style-warning #'compiler-style-warning-handler)
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 8ae84b755..dfee35b3d 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -574,31 +574,18 @@
(%mem-space nil :type (member nil :dynamic :immobile :auto))
;; the kind of component
;;
- ;; (The terminology here is left over from before
- ;; sbcl-0.pre7.34.flaky5.2, when there was no such thing as
- ;; FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P, so that Python was
- ;; incapable of building standalone :EXTERNAL functions, but instead
- ;; had to implement things like #'CL:COMPILE as FUNCALL of a little
- ;; toplevel stub whose sole purpose was to return an :EXTERNAL
- ;; function.)
- ;;
;; The possibilities are:
;; NIL
;; an ordinary component, containing non-top-level code
;; :TOPLEVEL
;; a component containing only load-time code
;; :COMPLEX-TOPLEVEL
- ;; In the old system, before FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P
- ;; was defined, this was necessarily a component containing both
- ;; top level and run-time code. Now this state is also used for
- ;; a component with HAS-EXTERNAL-REFERENCES-P functionals in it.
+ ;; a component containing both top-level and run-time code
;; :INITIAL
;; the result of initial IR1 conversion, on which component
;; analysis has not been done
;; :DELETED
;; debris left over from component analysis
- ;;
- ;; See also COMPONENT-TOPLEVELISH-P.
(kind nil :type (member nil :toplevel :complex-toplevel :initial :deleted))
;; the blocks that are the dummy head and tail of the DFO
;;
@@ -833,8 +820,7 @@
;; I guess we state the type this way to avoid calling
;; LEGAL-FUN-NAME-P unless absolutely necessary,
;; but this seems a bit of a premature optimization.
- :type (or symbol (and cons #-host-quirks-cmu (satisfies legal-fun-name-p)))
- :read-only t)
+ :type (or symbol (and cons #-host-quirks-cmu (satisfies legal-fun-name-p))))
;; the type which values of this leaf must have
(type *universal-type* :type ctype)
;; the type which values of this leaf have last been defined to have
@@ -1048,8 +1034,7 @@
;; %SOURCE-NAME=FOO (or maybe .ANONYMOUS.?)
;; %DEBUG-NAME=(MACRO-FUNCTION FOO)
(%debug-name nil
- :type (or null (not (satisfies legal-fun-name-p)))
- :read-only t)
+ :type (or null (not (satisfies legal-fun-name-p))))
;; some information about how this function is used. These values
;; are meaningful:
;;
@@ -1111,14 +1096,6 @@
;; :ZOMBIE
;; Effectless [MV-]LET; has no BIND node.
(kind #.(functional-kind-attributes nil) :type attributes)
- ;; Is this a function that some external entity (e.g. the fasl dumper)
- ;; refers to, so that even when it appears to have no references, it
- ;; shouldn't be deleted? In the old days (before
- ;; sbcl-0.pre7.37.flaky5.2) this was sort of implicitly true when
- ;; KIND was :TOPLEVEL. Now it must be set explicitly, both for
- ;; :TOPLEVEL functions and for any other kind of functions that we
- ;; want to dump or return from #'CL:COMPILE or whatever.
- (has-external-references-p nil)
;; In a normal function, this is the external entry point (XEP)
;; lambda for this function, if any. Each function that is used
;; other than in a local call has an XEP, and all of the
@@ -1165,7 +1142,7 @@
(defun pretty-print-functional (functional stream)
(let ((name (functional-debug-name functional)))
(prin1 `(function
- ,(if (typep name '(cons (member xep tl-xep)))
+ ,(if (typep name '(cons (eql xep)))
(cadr name)
name))
stream)))
@@ -1285,25 +1262,6 @@
(where-from :test (not (eq where-from :assumed)))
(vars :prin1 (mapcar #'leaf-source-name vars)))
-;;; Before sbcl-0.7.0, there were :TOPLEVEL things which were magical
-;;; in multiple ways. That's since been refactored into the orthogonal
-;;; properties "optimized for locall with no arguments" and "externally
-;;; visible/referenced (so don't delete it)". The code <0.7.0 did a lot
-;;; of tests a la (EQ KIND :TOP_LEVEL) in the "don't delete it?" sense;
-;;; this function is a sort of literal translation of those tests into
-;;; the new world.
-;;;
-;;; FIXME: After things settle down, bare :TOPLEVEL might go away, at
-;;; which time it might be possible to replace the COMPONENT-KIND
-;;; :TOPLEVEL mess with a flag COMPONENT-HAS-EXTERNAL-REFERENCES-P
-;;; along the lines of FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P.
-(defun lambda-toplevelish-p (clambda)
- (or (functional-kind-eq clambda toplevel)
- (lambda-has-external-references-p clambda)))
-(defun component-toplevelish-p (component)
- (member (component-kind component)
- '(:toplevel :complex-toplevel)))
-
;;; The OPTIONAL-DISPATCH leaf is used to represent hairy lambdas. It
;;; is a FUNCTIONAL, like LAMBDA. Each legal number of arguments has a
;;; function which is called when that number of arguments is passed.
diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp
index 0e988b86e..6050cce93 100644
--- a/src/compiler/target-main.lisp
+++ b/src/compiler/target-main.lisp
@@ -15,94 +15,32 @@
;;;; CL:COMPILE
-(defun ir1-toplevel-for-compile (form name)
- (let* ((component (make-empty-component))
- (*current-component* component)
- (debug-name-tail (or name (name-lambdalike form)))
- (source-name (or name '.anonymous.)))
- (setf (component-name component) (debug-name 'initial-component debug-name-tail)
- (component-kind component) :initial)
- (let* ((fun (let ((*allow-instrumenting* t))
- (ir1-convert-lambdalike form
- :source-name source-name
- :ftype (and name
- (global-ftype name)))))
- ;; Convert the XEP using the policy of the real function. Otherwise
- ;; the wrong policy will be used for deciding whether to type-check
- ;; the parameters of the real function (via CONVERT-CALL /
- ;; PROPAGATE-TO-ARGS). -- JES, 2007-02-27
- (*lexenv* (make-lexenv :policy (lexenv-policy (functional-lexenv fun))))
- (xep (ir1-convert-lambda (make-xep-lambda-expression fun)
- :source-name source-name
- :debug-name (debug-name 'tl-xep debug-name-tail))))
- (when name
- (assert-new-definition xep fun))
- (setf (functional-kind xep) (functional-kind-attributes external)
- (functional-entry-fun xep) fun
- (functional-entry-fun fun) xep
- (component-reanalyze component) t
- (functional-has-external-references-p xep) t)
- (reoptimize-component component :maybe)
- (locall-analyze-xep-entry-point fun)
- ;; Any leftover REFs to FUN outside local calls get replaced with the
- ;; XEP.
- (substitute-leaf-if (lambda (ref)
- (let* ((lvar (ref-lvar ref))
- (dest (when lvar (lvar-dest lvar)))
- (kind (when (basic-combination-p dest)
- (basic-combination-kind dest))))
- (neq :local kind)))
- xep
- fun)
- xep)))
-
-;;; Compile LAMBDA-EXPRESSION and return the compiled FUNCTION value.
-;;;
-;;; If NAME is provided, then we try to use it as the name of the
-;;; function for debugging/diagnostic information.
-(defun %compile (form ephemeral name)
+;;; Find the function that is being compiled by COMPILE and bash its
+;;; name to NAME. We also substitute for any references to name so
+;;; that recursive calls will be compiled direct. LAMBDA is the
+;;; top-level lambda for the compilation. The real function is the
+;;; only thing in the top-level lambda that is returned, so it isn't
+;;; too hard to find.
+(defun compile-fix-function-name (lambda name)
+ (declare (type clambda lambda) (type (or symbol cons) name))
(when name
- (legal-fun-name-or-type-error name))
- (with-ir1-namespace
- (let* ((*lexenv* (make-lexenv
- :policy *policy*
- :handled-conditions *handled-conditions*
- :disabled-package-locks *disabled-package-locks*))
- (*compile-object* (make-core-object ephemeral))
- (lambda (ir1-toplevel-for-compile form name)))
+ ;; FIXME: Shouldn't we check here that NAME is not an accessor or
+ ;; something already?
+ (let ((fun (ref-leaf
+ (lvar-use
+ (return-result (lambda-return lambda))))))
+ (setf (leaf-%source-name fun) name)
+ (setf (functional-%debug-name fun) nil)
+ (let ((old (gethash name (free-funs *ir1-namespace*))))
+ (when old (substitute-leaf-if
+ (lambda (ref)
+ (policy ref (> recognize-self-calls 0)))
+ fun old)))
+ name)))
- ;; FIXME: The compile-it code from here on is sort of a
- ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
- ;; better to find a way to share the code there; or
- ;; alternatively, to use this code to replace the code there.
- ;; (The second alternative might be pretty easy if we used
- ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
- ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
-
- (locall-analyze-clambdas-until-done (list lambda))
-
- (dolist (component (find-initial-dfo (list lambda)))
- (compile-component component))
-
- (let ((object *compile-object*))
- (multiple-value-bind (res found-p)
- (gethash (leaf-info lambda) (core-object-entry-table object))
- (aver found-p)
- (fix-core-source-info *source-info* object
- (and (policy (lambda-bind lambda)
- (> store-source-form 0))
- res))
- res)))))
-
-;;; Handle the following:
-;;; - CL:COMPILE when the argument is not already a compiled function.
-;;; - %SIMPLE-EVAL in "pretend we don't have an interpreter" mode
-;;; a/k/a "compile all the things"
-;;; - SB-INTERPRETER::EVAL-IN-ENVIRONMENT when it can't just do that.
-
-;;; If ERORRP is true signals an error immediately -- otherwise returns
-;;; a function that will signal the error.
-(defun compile-in-lexenv (form *lexenv* name source-info tlf ephemeral errorp)
+;;; If ERORRP is true signals an error immediately -- otherwise
+;;; returns a function that will signal the error.
+(defun %compile-in-lexenv (form *lexenv* name source-info tlf ephemeral errorp for-eval)
;; This ridiculous check for a NIL-returning constant function cuts out hundreds of
;; identical functions that result from all the turds that users seem to generate.
;; It's not coming from CLOS per se because our DEFCLASS knows to use :INITFUNCTION
@@ -116,103 +54,133 @@
(equal cdr '('nil))))))
;; I sure hope that users don't expect COMPILE to necessarily return a
;; unique blob of code. How could they?
- (return-from compile-in-lexenv
+ (return-from %compile-in-lexenv
(values (if (policy *lexenv* (= safety 0))
(load-time-value #'constantly-nil t)
(load-time-value #'sb-impl::0-arg-nil t))
nil nil)))
- (let ((source-paths (when source-info *source-paths*)))
- (with-compilation-values
- (with-compilation-unit ()
- (let ((*last-error-context* nil)
- (*last-message-count* (list* 0 nil nil)))
- (handler-bind ((compiler-error #'compiler-error-handler)
- (style-warning #'compiler-style-warning-handler)
- (warning #'compiler-warning-handler))
+ (with-compilation-values (:just-values for-eval)
+ (prog ((source-paths (when source-info *source-paths*))
+ (compile-object (make-core-object ephemeral))
+ (oops nil))
+ (handler-bind ((compiled-program-error
+ (lambda (e)
+ (setf oops e)
+ ;; Unwind the compiler frames: users want the know where
+ ;; the error came from, not how the compiler got there.
+ (go :error))))
+ (return
+ (core-call-toplevel-lambda
;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
;; few changes. Once things are stable, the shared bindings
;; probably be merged back together into some shared utility
;; macro, or perhaps both merged into one of the existing utility
;; macros SB-C::WITH-COMPILATION-VALUES or
;; CL:WITH-COMPILATION-UNIT.
- (with-source-paths
- (prog* ((tlf (or tlf 0))
- ;; If we have a source-info from LOAD, we will
- ;; also have a source-paths already set up -- so drop
- ;; the ones from WITH-COMPILATION-VALUES.
- (*source-paths* (or source-paths *source-paths*))
- (*source-info* (or source-info
- (make-lisp-source-info
- form :parent *source-info*)))
- (*allow-instrumenting* nil)
- (*compilation*
- (make-compilation
- (and (member :msan *features*)
- (find-dynamic-foreign-symbol-address "__msan_unpoison"))))
- (*gensym-counter* 0)
- ;; KLUDGE: This rebinding of policy is necessary so that
- ;; forms such as LOCALLY at the REPL actually extend the
- ;; compilation policy correctly. However, there is an
- ;; invariant that is potentially violated: future
- ;; refactoring must not allow this to be done in the file
- ;; compiler. At the moment we're clearly alright, as we
- ;; call %COMPILE with a core-object, not a fasl-stream,
- ;; but caveat future maintainers. -- CSR, 2002-10-27
- (*policy* (lexenv-policy *lexenv*))
- ;; see above
- (*handled-conditions* (lexenv-handled-conditions *lexenv*))
- ;; ditto
- (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))
- ;; FIXME: ANSI doesn't say anything about CL:COMPILE
- ;; interacting with these variables, so we shouldn't. As
- ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
- ;; binding these variables, so as a quick hack we do so
- ;; too. But a proper implementation would have verbosity
- ;; controlled by function arguments and lexical variables.
- (*compile-verbose* nil)
- (*compile-print* nil)
- ;; in some circumstances, we can trigger execution
- ;; of user code during optimization, which can
- ;; re-enter the compiler through explicit calls to
- ;; EVAL or COMPILE. Those inner evaluations
- ;; shouldn't attempt to report any compiler problems
- ;; using the outer compiler error context.
- (*compiler-error-context* nil)
- (oops nil))
- (handler-bind (((satisfies handle-condition-p) 'handle-condition-handler))
- (unless source-paths
- (find-source-paths form tlf))
- (let ((*current-path* (or (get-source-path form)
- (cons form (or (and (boundp '*current-path*)
- *current-path*)
- `(original-source-start 0 ,tlf)))))
- (*compiler-error-bailout*
- (lambda (e)
- (setf oops e)
- ;; Unwind the compiler frames: users want the know where
- ;; the error came from, not how the compiler got there.
- (go :error))))
- (return
- (%compile form ephemeral name))))
- :error
- ;; Either signal the error right away, or return a function that
- ;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so
- ;; that we retain our earlier behaviour when called with erronous
- ;; lambdas via %SIMPLE-EVAL. We could legally do just either one
- ;; always, but right now keeping the old behaviour seems like less
- ;; painful option: compiler.pure.lisp is full of tests that make all
- ;; sort of assumptions about when which things are signalled. FIXME,
- ;; probably.
- (if errorp
- (error oops)
- (let ((message (princ-to-string oops))
- (source (source-to-string form)))
- (return
- (lambda (&rest arguments)
- (declare (ignore arguments))
- (error 'compiled-program-error
- :message message
- :source source)))))))))))))
+ (with-compilation-unit ()
+ (let* ((*last-error-context* nil)
+ (*last-message-count* (list* 0 nil nil)))
+ (handler-bind ((compiler-error #'compiler-error-handler)
+ (style-warning #'compiler-style-warning-handler)
+ (warning #'compiler-warning-handler))
+ (with-source-paths
+ (let* ((tlf (or tlf 0))
+ ;; If we have a source-info from LOAD, we will
+ ;; also have a source-paths already set up -- so drop
+ ;; the ones from WITH-COMPILATION-VALUES.
+ (*source-paths* (or source-paths *source-paths*))
+ (*source-info* (or source-info
+ (make-lisp-source-info
+ form :parent *source-info*)))
+ (*allow-instrumenting* nil)
+ (*compilation*
+ (make-compilation
+ (and (member :msan *features*)
+ (find-dynamic-foreign-symbol-address "__msan_unpoison"))))
+ (*gensym-counter* 0)
+ ;; KLUDGE: This rebinding of policy is necessary so that
+ ;; forms such as LOCALLY at the REPL actually extend the
+ ;; compilation policy correctly. However, there is an
+ ;; invariant that is potentially violated: future
+ ;; refactoring must not allow this to be done in the file
+ ;; compiler. At the moment we're clearly alright, as we
+ ;; call %COMPILE with a core-object, not a fasl-stream,
+ ;; but caveat future maintainers. -- CSR, 2002-10-27
+ (*policy* (lexenv-policy *lexenv*))
+ ;; see above
+ (*handled-conditions* (lexenv-handled-conditions *lexenv*))
+ ;; ditto
+ (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))
+ ;; FIXME: ANSI doesn't say anything about CL:COMPILE
+ ;; interacting with these variables, so we shouldn't. As
+ ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
+ ;; binding these variables, so as a quick hack we do so
+ ;; too. But a proper implementation would have verbosity
+ ;; controlled by function arguments and lexical variables.
+ (*compile-verbose* nil)
+ (*compile-print* nil)
+ ;; in some circumstances, we can trigger execution
+ ;; of user code during optimization, which can
+ ;; re-enter the compiler through explicit calls to
+ ;; EVAL or COMPILE. Those inner evaluations
+ ;; shouldn't attempt to report any compiler problems
+ ;; using the outer compiler error context.
+ (*compiler-error-context* nil))
+ (handler-bind (((satisfies handle-condition-p) 'handle-condition-handler))
+ (unless source-paths
+ (find-source-paths form tlf))
+ (with-ir1-namespace
+ (let* ((*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
+ (*compile-object* compile-object)
+ (path (or (get-source-path form)
+ (cons form (or (and (boundp '*current-path*)
+ *current-path*)
+ `(original-source-start 0 ,tlf)))))
+ (lambda (ir1-toplevel form path t)))
+
+ (compile-fix-function-name lambda name)
+ (locall-analyze-clambdas-until-done (list lambda))
+
+ (multiple-value-bind (components top-components)
+ (find-initial-dfo (list lambda))
+ (dolist (component (append components top-components))
+ (compile-component component)))
+
+ (fix-core-source-info *source-info* *compile-object*
+ (policy (lambda-bind lambda)
+ (> store-source-form 0)))
+
+ lambda))))))))
+ compile-object)))
+ :error
+ ;; Either signal the error right away, or return a function that
+ ;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so
+ ;; that we retain our earlier behaviour when called with erronous
+ ;; lambdas via %SIMPLE-EVAL. We could legally do just either one
+ ;; always, but right now keeping the old behaviour seems like less
+ ;; painful option: compiler.pure.lisp is full of tests that make all
+ ;; sort of assumptions about when which things are signalled. FIXME,
+ ;; probably.
+ (if errorp
+ (%program-error (sb-kernel::program-error-message oops))
+ (return
+ (lambda (&rest arguments)
+ (declare (ignore arguments))
+ (error oops)))))))
+
+(defun eval-with-compile-in-lexenv (form *lexenv* source-info tlf ephemeral)
+ (%compile-in-lexenv form *lexenv* nil source-info tlf ephemeral t t))
+
+(defun compile-in-lexenv (form *lexenv* name source-info tlf ephemeral errorp)
+ (unless (typep form '(cons (member lambda named-lambda) t))
+ (compiler-error "Not a valid lambda expression:~% ~S"
+ form))
+ (when name
+ (legal-fun-name-or-type-error name))
+ (%compile-in-lexenv form *lexenv* name source-info tlf ephemeral errorp nil))
;;; NOTE: COMPILE may be slightly nonconforming regarding generic functions,
;;; but no more nonconforming than it was prior to the redefinition of
@@ -253,24 +221,24 @@ Tertiary value is true if any conditions of type ERROR, or WARNING that are
not STYLE-WARNINGs occur during compilation, and NIL otherwise.
"
(binding*
- (((start-sec start-nsec) (get-thread-virtual-time))
- ((compiled-definition warnings-p failure-p)
- (if (or (compiled-function-p definition)
- (sb-pcl::generic-function-p definition))
- ;; We're not invoking COMPILE. If NAME isn't NIL then we need to
- ;; ensure that DEFINITION (if supplied) gets bound to NAME even if
- ;; (COMPILED-FUNCTION-P #'NAME) => NIL afterwards.
- ;; This is a minor bug if DEFINITION is a GENERIC-FUNCTION with
- ;; at least one interpreted method.
- (values (if (and name defp) definition (make-unbound-marker))
- nil nil)
- (multiple-value-bind (sexpr lexenv)
- (if (not (typep definition 'interpreted-function))
- (values (the cons definition) (make-null-lexenv))
- #+(or sb-eval sb-fasteval)
- (prepare-for-compile definition))
- (sb-vm:without-arena "compile"
- (compile-in-lexenv sexpr lexenv name nil nil nil nil))))))
+ (((start-sec start-nsec) (get-thread-virtual-time))
+ ((compiled-definition warnings-p failure-p)
+ (if (or (compiled-function-p definition)
+ (sb-pcl::generic-function-p definition))
+ ;; We're not invoking COMPILE. If NAME isn't NIL then we need to
+ ;; ensure that DEFINITION (if supplied) gets bound to NAME even if
+ ;; (COMPILED-FUNCTION-P #'NAME) => NIL afterwards.
+ ;; This is a minor bug if DEFINITION is a GENERIC-FUNCTION with
+ ;; at least one interpreted method.
+ (values (if (and name defp) definition (make-unbound-marker))
+ nil nil)
+ (multiple-value-bind (sexpr lexenv)
+ (if (not (typep definition 'interpreted-function))
+ (values (the cons definition) (make-null-lexenv))
+ #+(or sb-eval sb-fasteval)
+ (prepare-for-compile definition))
+ (sb-vm:without-arena "compile"
+ (compile-in-lexenv sexpr lexenv name nil nil nil nil))))))
(accumulate-compiler-time '*compile-elapsed-time* start-sec start-nsec)
(values (cond (name
;; Do NOT assign anything into the symbol if we did not
diff --git a/src/interpreter/eval.lisp b/src/interpreter/eval.lisp
index b71937373..f7b83ee5d 100644
--- a/src/interpreter/eval.lisp
+++ b/src/interpreter/eval.lisp
@@ -227,16 +227,9 @@
(sb-kernel:lexenv (if (sb-c::null-lexenv-p env) nil (env-from-lexenv env)))
(t env))))
(if (eq interpreter-env :compile)
- (funcall (handler-case
- ;; Final arg of T means signal errors immediately rather
- ;; than returning a function that signals when called.
- (sb-c:compile-in-lexenv `(lambda () ,form) env nil nil nil nil t)
- (error ()
- ;; Whatever went wrong, just say "too complex"
- (error 'compiler-environment-too-complex-error
- :format-control
- "~@<Lexical environment is too complex to evaluate in: ~S~:@>"
- :format-arguments (list env)))))
+ ;; Final arg of T means signal errors immediately rather than
+ ;; returning a function that signals when called.
+ (sb-c:eval-with-compile-in-lexenv form env nil nil t)
;; FIXME: should this be (OR INTERPRETER-ENV (CAPTURE-TOPLEVEL-ENV)) ?
;; Whether we decide to capture the policy here or not, there will always
;; be some use-case that comes out wrong. Capturing it is necessary for
diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp
index 60d2b060a..63bd37bba 100644
--- a/src/pcl/fngen.lisp
+++ b/src/pcl/fngen.lisp
@@ -45,20 +45,24 @@
`(lambda ,args-copy . ,body))))))))
(sb-vm:without-arena "pcl-compile"
(let* ((base-policy sb-c::*policy*)
+ (pcl-policy
+ (sb-c::process-optimize-decl
+ '(optimize (sb-c:store-source-form 0) (sb-c::store-xref-data 0))
+ base-policy))
(lexenv
(sb-c::make-almost-null-lexenv
(ecase safety
;; Stepping invokes the printer on forms, which might
;; invoke print-object, which might require dispatch
;; function recompilation.
- (:safe (if (sb-c:policy base-policy (= sb-c:insert-step-conditions 0))
- base-policy
+ (:safe (if (sb-c:policy pcl-policy (= sb-c:insert-step-conditions 0))
+ pcl-policy
(sb-c::process-optimize-decl '(optimize (sb-c:insert-step-conditions 0))
- base-policy)))
+ pcl-policy)))
(:unsafe (sb-c::process-optimize-decl
'(optimize (space 1) (compilation-speed 1)
(speed 3) (safety 0) (sb-ext:inhibit-warnings 3) (debug 0))
- base-policy)))
+ pcl-policy)))
;; I suspect that INHIBIT-WARNINGS precludes them from happening
(list (cons (sb-kernel:find-classoid 'style-warning) 'muffle-warning)
(cons (sb-kernel:find-classoid 'compiler-note) 'muffle-warning))
diff --git a/tests/compiler-2.impure.lisp b/tests/compiler-2.impure.lisp
index 90d436b9d..55ea3c6f8 100644
--- a/tests/compiler-2.impure.lisp
+++ b/tests/compiler-2.impure.lisp
@@ -71,7 +71,9 @@
(let ((sb-c::*compile-to-memory-space* :immobile))
(compile nil lambda)))
(end-count (count-code-objects)))
- (assert (= end-count (1+ start-count)))
+ ;; 2 components because the load time component used
+ ;; to return the actual function is included as well.
+ (assert (= end-count (+ start-count 2)))
result))))
(sb-ext:gc :full t)
;; Test 1: simple macrolet
@@ -258,3 +260,21 @@
(specialized-xep-ignored-var 1 d))
((2d0) 2d0)
((-2d0) -2d0)))
+
+;;; Check that non-COMPILE-FILE'd evaluated forms do not retain any
+;;; toplevel code.
+(let ((x 4))
+ (print x)
+ (print (+ x x))
+ (print (* x x x))
+ (defun eval-top-level-test (z)
+ z))
+
+(with-test (:name :eval-top-level-code-separate-component
+ :skipped-on :interpreter)
+ ;; Check there's no top level code hanging out.
+ (assert (= 1 (sb-kernel::code-n-entries
+ (sb-kernel::fun-code-header
+ (sb-kernel::%closure-fun
+ (symbol-function 'eval-top-level-test))))))
+ (assert (= (funcall 'eval-top-level-test 4) 4)))
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index 086e59d0d..6037610e0 100644
--- a/tests/compiler-2.pure.lisp
+++ b/tests/compiler-2.pure.lisp
@@ -4613,61 +4613,6 @@
(f)))))))
:allow-notes 'code-deletion-note))
-(declaim (ftype (function (&key (:a fixnum)) t) ftype-test-key)
- (ftype (function (&optional fixnum) t) ftype-test-opt)
- (ftype (function (&optional fixnum &key (:b integer)) t) ftype-test-opt-key))
-(defun ftype-test-key (&key (a nil))
- a)
-(defun ftype-test-opt (&optional (a nil))
- a)
-(defun ftype-test-opt-key (&optional (a nil) &key (b nil))
- (declare (muffle-conditions style-warning))
- (values a b))
-
-(compile 'ftype-test-key)
-(compile 'ftype-test-opt)
-(compile 'ftype-test-opt-key)
-
-(with-test (:name :ftype-optional)
- (checked-compile-and-assert
- ()
- `(lambda ()
- (ftype-test-opt))
- (() nil))
- (checked-compile-and-assert
- ()
- `(lambda ()
- (ftype-test-key))
- (() nil))
- (checked-compile-and-assert
- ()
- `(lambda (a)
- (ftype-test-key :a a))
- ((nil) (condition 'type-error)))
- (checked-compile-and-assert
- ()
- `(lambda (a)
- (ftype-test-opt a))
- ((nil) (condition 'type-error)))
- (checked-compile-and-assert
- ()
- `(lambda (a)
- (ftype-test-opt-key a))
- ((nil) (condition 'type-error)))
- (checked-compile-and-assert
- ()
- `(lambda (a b)
- (ftype-test-opt-key a :b b))
- ((0 nil) (condition 'type-error)))
- (assert (type-specifiers-equal
- (caddr
- (sb-kernel:%simple-fun-type #'ftype-test-key))
- '(values (or null fixnum) &optional)))
- (assert (type-specifiers-equal
- (caddr
- (sb-kernel:%simple-fun-type #'ftype-test-opt))
- '(values (or null fixnum) &optional))))
-
;;; This trivial function failed to compile due to rev 88d078fe
(with-test (:name :make-list-reduce)
(checked-compile
@@ -5126,17 +5071,6 @@
((8) t)
((0) nil)))
-(declaim (ftype (function (&key (:a integer)) t) ftype-key-default-type))
-(with-test (:name :ftype-key-default-type)
- (assert-type
- (sb-int:named-lambda ftype-key-default-type (&key (a (isqrt *)))
- a)
- integer)
- (assert-type
- (sb-int:named-lambda ftype-key-default-type (&key (a 1))
- a)
- integer))
-
(with-test (:name :deleted-node-in-derive-type)
(checked-compile
`(lambda (a)
@@ -5152,3 +5086,38 @@
(lambda (a) (+ a 1)))
1))
(integer 2 3)))
+
+(with-test (:name :compile-name-correct)
+ (let ((gensym (gensym)))
+ (assert (eq (sb-kernel:%fun-name
+ (symbol-function
+ (checked-compile
+ `(lambda (a)
+ (declare ((simple-array nil (9)) a))
+ (setf (aref a 0) 1)
+ a)
+ :name gensym)))
+ gensym))))
+
+(declaim (ftype function self-call))
+(with-test (:name :compile-self-call-policy.1)
+ (let ((fun (symbol-function
+ (checked-compile
+ `(lambda (a)
+ (declare (optimize (sb-c::recognize-self-calls 0)))
+ (if (zerop a)
+ 2
+ (self-call (1- a))))
+ :name 'self-call))))
+ (assert (member 'self-call (ctu:find-named-callees fun)))))
+
+(with-test (:name :compile-self-call-policy.1)
+ (let ((fun (symbol-function
+ (checked-compile
+ `(lambda (a)
+ (declare (optimize sb-c::recognize-self-calls))
+ (if (zerop a)
+ 2
+ (self-call (1- a))))
+ :name 'self-call))))
+ (assert (not (member 'self-call (ctu:find-named-callees fun))))))
diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp
index 62d8af7d0..c41931402 100644
--- a/tests/compiler.pure-cload.lisp
+++ b/tests/compiler.pure-cload.lisp
@@ -211,24 +211,79 @@
(defun component-xep-references.4 ()
(component-xep-references-mi 1)))
-(declaim (ftype (function (&key (:a fixnum)) t) compiled-ftype-test-key)
- (ftype (function (&optional fixnum) t) compiled-ftype-test-opt))
+(declaim (ftype (function (&key (:a fixnum)) t) ftype-test-key)
+ (ftype (function (&optional fixnum) t) ftype-test-opt)
+ (ftype (function (&optional fixnum &key (:b integer)) t) ftype-test-opt-key))
+(defun ftype-test-key (&key (a nil))
+ a)
+(defun ftype-test-opt (&optional (a nil))
+ a)
+(defun ftype-test-opt-key (&optional (a nil) &key (b nil))
+ (declare (muffle-conditions style-warning))
+ (values a b))
-(defun compiled-ftype-test-key (&key a)
- a)
-(defun compiled-ftype-test-opt (&optional (a nil))
- a)
+(compile 'ftype-test-key)
+(compile 'ftype-test-opt)
+(compile 'ftype-test-opt-key)
(with-test (:name :ftype-optional)
+ (checked-compile-and-assert
+ ()
+ `(lambda ()
+ (ftype-test-opt))
+ (() nil))
+ (checked-compile-and-assert
+ ()
+ `(lambda ()
+ (ftype-test-key))
+ (() nil))
+ (checked-compile-and-assert
+ ()
+ `(lambda (a)
+ (ftype-test-key :a a))
+ ((nil) (condition 'type-error)))
+ (checked-compile-and-assert
+ ()
+ `(lambda (a)
+ (ftype-test-opt a))
+ ((nil) (condition 'type-error)))
+ (checked-compile-and-assert
+ ()
+ `(lambda (a)
+ (ftype-test-opt-key a))
+ ((nil) (condition 'type-error)))
+ (checked-compile-and-assert
+ ()
+ `(lambda (a b)
+ (ftype-test-opt-key a :b b))
+ ((0 nil) (condition 'type-error)))
(assert (type-specifiers-equal
(caddr
- (sb-kernel:%simple-fun-type #'compiled-ftype-test-key))
+ (sb-kernel:%simple-fun-type #'ftype-test-key))
'(values (or null fixnum) &optional)))
(assert (type-specifiers-equal
(caddr
- (sb-kernel:%simple-fun-type #'compiled-ftype-test-opt))
+ (sb-kernel:%simple-fun-type #'ftype-test-opt))
'(values (or null fixnum) &optional))))
+(declaim (ftype (function (&key (:a integer)) t)
+ ftype-key-default-type
+ ftype-key-default-type-2))
+(defun ftype-key-default-type (&key (a (isqrt *)))
+ a)
+
+(defun ftype-key-default-type-2 (&key (a 1))
+ a)
+(with-test (:name :ftype-key-default-type)
+ (assert (type-specifiers-equal
+ (caddr
+ (sb-kernel:%simple-fun-type #'ftype-key-default-type))
+ '(values integer &optional)))
+ (assert (type-specifiers-equal
+ (caddr
+ (sb-kernel:%simple-fun-type #'ftype-key-default-type-2))
+ '(values integer &optional))))
+
(defun ltv-constants ()
(load-time-value (char-code #\a)))
diff --git a/tests/slot-value.impure.lisp b/tests/slot-value.impure.lisp
index 173ed06d6..aedfcad11 100644
--- a/tests/slot-value.impure.lisp
+++ b/tests/slot-value.impure.lisp
@@ -92,13 +92,11 @@
(let* ((method (find-method #'read-a-struct-x nil (list (find-class 'a-struct))))
(mf (sb-mop:method-function method))
(fmf (sb-pcl::%method-function-fast-function mf))
- (callees (ctu:find-named-callees fmf))
- (pcl-callees '(sb-pcl::method-function-from-fast-function sb-pcl::%make-method-function)))
+ (callees (ctu:find-named-callees fmf)))
(ecase sb-ext:*evaluator-mode*
(:interpret)
(:compile
- (assert (null (set-difference pcl-callees callees)))
- (assert (null (set-difference callees pcl-callees)))))))
+ (assert (null callees))))))
(with-test (:name :structure-missing-slot-value-in-method-calls-global
:skipped-on (not (or :x86 :x86-64)))
@@ -110,13 +108,11 @@
(let* ((method (find-method #'read-a-struct-y nil (list (find-class 'a-struct))))
(mf (sb-mop:method-function method))
(fmf (sb-pcl::%method-function-fast-function mf))
- (callees (ctu:find-named-callees fmf))
- (pcl-callees '(sb-pcl::method-function-from-fast-function sb-pcl::%make-method-function)))
+ (callees (ctu:find-named-callees fmf)))
(ecase sb-ext:*evaluator-mode*
(:interpret)
(:compile
- (assert (null (set-difference pcl-callees callees)))
- (assert (equal (set-difference callees pcl-callees) '(sb-pcl::structure-slot-value)))))))
+ (assert (equal callees '(sb-pcl::structure-slot-value)))))))
(define-condition a-condition () ((a :initarg :a)))
(defmethod sb-mop:slot-value-using-class :around (class (c a-condition) slotd)
diff --git a/tests/time.pure.lisp b/tests/time.pure.lisp
index 8c161e815..10ac3c173 100644
--- a/tests/time.pure.lisp
+++ b/tests/time.pure.lisp
@@ -28,4 +28,7 @@
(with-test (:name (time :lambdas-converted))
(let ((output (with-output-to-string (*trace-output*)
(time (checked-compile '(lambda () 42))))))
- (assert (search "1 lambda converted" output))))
+ ;; We just want to confirm that some number of lambdas have been
+ ;; converted. The exact number depends on the inner workings of
+ ;; the compiler.
+ (assert (search "converted" output))))
diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr
index 5651ee9cd..767d8f401 100644
--- a/xperfecthash63.lisp-expr
+++ b/xperfecthash63.lisp-expr
@@ -1706,5 +1706,8 @@
(let ((b (& (>> val 5) #x7)))
(let ((a (>> (<< val 5) 29)))
(^ a (aref tab b))))))")
+(#(EA1E569 42D83FFB 6634E9C8 825503B8 8D9B0A28 ADDD7F24)
+ "(:ALLOW-OTHER-KEYS :FORM :PLIST :START-POSITIONS :CREATED :NAMESTRING)"
+ "((& (^ (>> val 10) (>> val 28)) 7))")
)
;; EOF
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL