branch compile-for-eval: created. sbcl-2.6.4-48-ge6ed41a79
apache--- via Sbcl-commits <[email protected]> Sun, 17 May 2026 02:19:05 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "compile-for-eval" has been created in SBCL:
at e6ed41a793db32b173f1f39c780b0e59cfb572ad (commit)
- Log -----------------------------------------------------------------
commit e6ed41a793db32b173f1f39c780b0e59cfb572ad
Author: Charles Zhang <[email protected]>
Date: Thu Dec 15 12:09:51 2022 +0100
Use plain IR1-TOPLEVEL for CL:COMPILE and %SIMPLE-EVAL.
* 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. Additionally, this allows %SIMPLE-EVAL to not have to
manually wrap the lambdas either, so evaluation-via-compilation behaves
like top-level evaluation by the file compiler.
* 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.
---
src/code/time.lisp | 3 +-
src/compiler/debug-dump.lisp | 2 +-
src/compiler/debug.lisp | 3 +-
src/compiler/dfo.lisp | 32 +++--------
src/compiler/entry.lisp | 61 ++++++++++-----------
src/compiler/envanal.lisp | 3 +-
src/compiler/ir1tran-lambda.lisp | 6 +--
src/compiler/ir1util.lisp | 4 +-
src/compiler/locall.lisp | 20 +++----
src/compiler/main.lisp | 2 -
src/compiler/node.lisp | 44 +--------------
src/compiler/target-main.lisp | 114 +++++++++++----------------------------
src/pcl/fngen.lisp | 12 +++--
tests/compiler-2.impure.lisp | 4 +-
tests/compiler-2.pure.lisp | 66 -----------------------
tests/compiler.pure-cload.lisp | 71 +++++++++++++++++++++---
tests/time.pure.lisp | 5 +-
17 files changed, 161 insertions(+), 291 deletions(-)
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/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index f4ed920e3..dee9f72a1 100644
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -768,7 +768,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/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 3f07bdc74..d5821417d 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/main.lisp b/src/compiler/main.lisp
index aa946e866..bae53cf70 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -655,8 +655,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
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 025659303..d50d871af 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -560,31 +560,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
;;
@@ -1097,14 +1084,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
@@ -1151,7 +1130,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)))
@@ -1271,25 +1250,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..c2b62d278 100644
--- a/src/compiler/target-main.lisp
+++ b/src/compiler/target-main.lisp
@@ -15,52 +15,11 @@
;;;; 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)
+(defun %compile (form ephemeral name tlf)
(when name
(legal-fun-name-or-type-error name))
(with-ir1-namespace
@@ -69,30 +28,25 @@
:handled-conditions *handled-conditions*
:disabled-package-locks *disabled-package-locks*))
(*compile-object* (make-core-object ephemeral))
- (lambda (ir1-toplevel-for-compile form 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..)
+ (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)))
(locall-analyze-clambdas-until-done (list lambda))
- (dolist (component (find-initial-dfo (list lambda)))
- (compile-component component))
+ (multiple-value-bind (components top-components)
+ (find-initial-dfo (list lambda))
+ (dolist (component (append components top-components))
+ (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)))))
+ (let ((res (core-call-toplevel-lambda lambda *compile-object*)))
+ (fix-core-source-info *source-info* *compile-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.
@@ -179,21 +133,17 @@
;; using the outer compiler error context.
(*compiler-error-context* nil)
(oops nil))
- (handler-bind (((satisfies handle-condition-p) 'handle-condition-handler))
+ (handler-bind (((satisfies handle-condition-p) 'handle-condition-handler)
+ (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))))
(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))))
+ (return
+ (%compile form ephemeral name tlf)))
:error
;; Either signal the error right away, or return a function that
;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so
@@ -204,15 +154,11 @@
;; 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)))))))))))))
+ (%program-error (sb-kernel::program-error-message oops))
+ (return
+ (lambda (&rest arguments)
+ (declare (ignore arguments))
+ (error oops))))))))))))
;;; NOTE: COMPILE may be slightly nonconforming regarding generic functions,
;;; but no more nonconforming than it was prior to the redefinition of
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..be036b549 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
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index 086e59d0d..86ac60118 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)
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/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))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL