Menu
▾
▴
[Sbcl-commits] master: Fix discrepancies in handling toplevel forms per CLHS 3.2.3.1
|
From: Douglas K. <sn...@us...> - 2014-07-29 22:35:11
|
The branch "master" has been updated in SBCL:
via 437490ed66172686a3f9d1d264b66fa2cfb2bb8e (commit)
from 0ad7c5ca279e332b616666e92782ca1ec8e15f16 (commit)
- Log -----------------------------------------------------------------
commit 437490ed66172686a3f9d1d264b66fa2cfb2bb8e
Author: Douglas Katzman <do...@go...>
Date: Tue Jul 29 18:31:58 2014 -0400
Fix discrepancies in handling toplevel forms per CLHS 3.2.3.1
This patch makes compiler macros be consistently used in file compilation
subject of course to the stipulation that NOTINLINE disables them.
Previously the main compiler didn't use a compiler-macro if a global
functoid was both a macro and compiler-macro, and the use was toplevel.
The fopcompiler never used compiler-macros, toplevel or not.
Such behavior was opaque and inexplicable to users except by an explanation
involving discussion of the loader's DSL and what it is capable of versus
truly compiled - i.e. assembly language - code.
Even to document the kinds of forms that are amenable to fop compilation
as a "remedy" to this issue would be a brittle one.
---
src/compiler/fopcompile.lisp | 17 ++++++++--
src/compiler/ir1tran.lisp | 44 +++++++++++++++-----------
src/compiler/main.lisp | 10 +++++-
tests/fopcompiler.impure-cload.lisp | 48 +++++++++++++++++++++++++++++
tests/fopcompiler.impure.lisp | 58 +++++++++++++++++++++++++---------
5 files changed, 138 insertions(+), 39 deletions(-)
diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp
index 9187c2b..683c70c 100644
--- a/src/compiler/fopcompile.lisp
+++ b/src/compiler/fopcompile.lisp
@@ -50,6 +50,10 @@
(member kind '(:special :constant :global :unknown))))))
(and (listp form)
(ignore-errors (list-length form))
+ (let ((macroexpansion (expand-compiler-macro form)))
+ (if (neq macroexpansion form)
+ (return-from fopcompilable-p (fopcompilable-p macroexpansion))
+ t))
(multiple-value-bind (macroexpansion macroexpanded-p)
(%macroexpand form *lexenv*)
(if macroexpanded-p
@@ -124,7 +128,7 @@
;; DECLARE would violate a package lock.
(not (eq operator 'declare))
(not (special-operator-p operator))
- (not (macro-function operator))
+ (not (macro-function operator)) ; redundant check
;; We can't FOP-FUNCALL with more than 255
;; parameters. (We could theoretically use
;; APPLY, but then we'd need to construct
@@ -274,6 +278,11 @@
path
for-value-p))))))))))
((listp form)
+ (let ((macroexpansion (expand-compiler-macro form)))
+ (if (neq macroexpansion form)
+ ;; could expand into an atom, so start from the top
+ (return-from fopcompile
+ (fopcompile macroexpansion path for-value-p))))
(multiple-value-bind (macroexpansion macroexpanded-p)
(%macroexpand form *lexenv*)
(if macroexpanded-p
@@ -291,9 +300,9 @@
((function)
(fopcompile-function (second form) path for-value-p))
;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
- ;; by a compiler-macro. Doing general compiler-macro
- ;; expansion in the fopcompiler is probably not sensible,
- ;; so we'll just special-case it.
+ ;; by a compiler-macro. But if SPACE > DEBUG we choose not
+ ;; to record locations, which is strange because the main
+ ;; compiler does not have similar logic afaict.
((source-location)
(if (policy *policy* (and (> space 1)
(> space debug)))
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 374942c..99d616b 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -732,34 +732,42 @@
(values (sb!xc:compiler-macro-function opname *lexenv*) opname)
(values nil nil))))
+;;; If FORM has a usable compiler macro, use it; otherwise return FORM itself.
+;;; Return the name of the compiler-macro as a secondary value, if applicable.
+(defun expand-compiler-macro (form)
+ (multiple-value-bind (cmacro-fun cmacro-fun-name)
+ (find-compiler-macro (car form) form)
+ (if (and cmacro-fun
+ ;; CLHS 3.2.2.1.3 specifies that NOTINLINE
+ ;; suppresses compiler-macros.
+ (not (fun-lexically-notinline-p cmacro-fun-name)))
+ (values (handler-case (careful-expand-macro cmacro-fun form t)
+ (compiler-macro-keyword-problem (c)
+ (print-compiler-message *error-output* "note: ~A" (list c))
+ form))
+ cmacro-fun-name)
+ (values form nil))))
+
;;; Picks off special forms and compiler-macro expansions, and hands
;;; the rest to IR1-CONVERT-COMMON-FUNCTOID
(defun ir1-convert-functoid (start next result form)
(let* ((op (car form))
(translator (and (symbolp op) (info :function :ir1-convert op))))
(cond (translator
+ ;; FIXME: redundant? A macro can not be defined in the first place.
(when (sb!xc:compiler-macro-function op *lexenv*)
(compiler-warn "ignoring compiler macro for special form"))
(funcall translator start next result form))
(t
- (multiple-value-bind (cmacro-fun cmacro-fun-name)
- (find-compiler-macro op form)
- (if (and cmacro-fun
- ;; CLHS 3.2.2.1.3 specifies that NOTINLINE
- ;; suppresses compiler-macros.
- (not (fun-lexically-notinline-p cmacro-fun-name)))
- (let ((res (handler-case
- (careful-expand-macro cmacro-fun form t)
- (compiler-macro-keyword-problem (c)
- (print-compiler-message *error-output* "note: ~A" (list c))
- form))))
- (cond ((eq res form)
- (ir1-convert-common-functoid start next result form op))
- (t
- (unless (policy *lexenv* (zerop store-xref-data))
- (record-call cmacro-fun-name (ctran-block start) *current-path*))
- (ir1-convert start next result res))))
- (ir1-convert-common-functoid start next result form op)))))))
+ (multiple-value-bind (res cmacro-fun-name)
+ (expand-compiler-macro form)
+ (cond ((eq res form)
+ (ir1-convert-common-functoid start next result form op))
+ (t
+ (unless (policy *lexenv* (zerop store-xref-data))
+ (record-call cmacro-fun-name (ctran-block start)
+ *current-path*))
+ (ir1-convert start next result res))))))))
;;; Handles the "common" cases: any other forms except special forms
;;; and compiler-macros.
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 1faddd6..8f735fc 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -1000,8 +1000,16 @@ necessary, since type inference may take arbitrarily long to converge.")
;;; Macroexpand FORM in the current environment with an error handler.
;;; We only expand one level, so that we retain all the intervening
-;;; forms in the source path.
+;;; forms in the source path. A compiler-macro takes precedence over
+;;; an ordinary macro as specified in CLHS 3.2.3.1
+;;; Note that this function is _only_ for processing of toplevel forms.
+;;; Non-toplevel forms use IR1-CONVERT-FUNCTOID which considers compiler macros.
(defun preprocessor-macroexpand-1 (form)
+ (if (listp form)
+ (let ((expansion (expand-compiler-macro form)))
+ (if (neq expansion form)
+ (return-from preprocessor-macroexpand-1
+ (values expansion t)))))
(handler-case (%macroexpand-1 form *lexenv*)
(error (condition)
(compiler-error "(during macroexpansion of ~A)~%~A"
diff --git a/tests/fopcompiler.impure-cload.lisp b/tests/fopcompiler.impure-cload.lisp
index 09e06c8..35ec45f 100644
--- a/tests/fopcompiler.impure-cload.lisp
+++ b/tests/fopcompiler.impure-cload.lisp
@@ -93,3 +93,51 @@
(let* ((x (bar (foo)))
(y (bar (x foo))))
(bar (y x foo))))
+
+;;; Some tests involving compiler-macros.
+
+(defvar *cmacro-result* nil)
+
+(defun baz (x) (declare (ignore x)))
+
+;; functional foo - a function with a compiler-macro
+(defun ffoo (x) (push `(regular-ffoo ,x) *cmacro-result*))
+(define-compiler-macro ffoo (x)
+ `(push `(cmacro-ffoo ,,x) *cmacro-result*))
+
+;; macro foo - a macro with a compiler-macro
+(defmacro mfoo (x) `(push `(regular-mfoo ,,x) *cmacro-result*))
+(define-compiler-macro mfoo (x)
+ `(push `(cmacro-mfoo ,,x) *cmacro-result*))
+
+(defun get-s () (declare (special s)) s)
+
+;; Verify some assumptions that the tests will test what was intended.
+(eval-when (:compile-toplevel)
+ (let ((sb-c::*lexenv* (sb-kernel:make-null-lexenv)))
+ (assert (sb-c::fopcompilable-p '(baz (ffoo 3))))
+ (assert (sb-c::fopcompilable-p '(baz (mfoo 3))))
+ ;; The special binding of S makes these forms not fopcompilable.
+ (assert (not (sb-c::fopcompilable-p
+ '(ffoo (let ((s 3)) (declare (special s)) (get-s))))))
+ (assert (not (sb-c::fopcompilable-p
+ '(mfoo (let ((s 3)) (declare (special s)) (get-s))))))))
+
+;; fopcompilable toplevel form should execute the compiler macro
+(ffoo 1)
+(mfoo 1)
+;; fopcompilable form expands embedded compiler-macro
+(baz (ffoo 2))
+(baz (mfoo 2))
+;; not-fopcompilable toplevel form should execute the compiler macro.
+;; This was ok if the toplevel call was a function with a compiler-macro,
+;; but was not working for a toplevel macro having a compiler-macro.
+(ffoo (let ((s 3)) (declare (special s)) (get-s)))
+(mfoo (let ((s 3)) (declare (special s)) (get-s)))
+
+(with-test (:name :compiler-macros-at-toplevel)
+ ;; Now assert about the macroexpansions that happened.
+ (assert (equal *cmacro-result*
+ '((CMACRO-MFOO 3) (CMACRO-FFOO 3)
+ (CMACRO-MFOO 2) (CMACRO-FFOO 2)
+ (CMACRO-MFOO 1) (CMACRO-FFOO 1)))))
diff --git a/tests/fopcompiler.impure.lisp b/tests/fopcompiler.impure.lisp
index 3aa5676..0f79838 100644
--- a/tests/fopcompiler.impure.lisp
+++ b/tests/fopcompiler.impure.lisp
@@ -10,27 +10,53 @@
;;;; more information.
;;; These tests don't need to be processed by the compiler before
-;;; being executed.
+;;; being executed, in fact mustn't go in "fopcompiler.impure-cload.lisp"
+;;; because the call to COMPILE-FILE needs to be wrapped in HANDLER-BIND.
(defvar *tmp-filename* "fopcompile-test.tmp")
-;; Ensure we can get a style-warning about undefined functions from FOPCOMPILE.
-(with-test (:name :fopcompiler-undefined-warning)
- (let ((form '(defvar *foo* (i-do-not-exist))))
- ;; Assert that the test case is handled by the fopcompiler.
- (let ((sb-c::*lexenv* (sb-kernel:make-null-lexenv)))
- (assert (sb-c::fopcompilable-p form)))
- ;; Make sure some wiseacre didn't defconstant *FOO*
- (assert (eq (sb-int:info :variable :kind '*foo*) :unknown))
- ;; ... or define the I-DO-NOT-EXIST function.
- (assert (eq (sb-int:info :function :where-from 'i-do-not-exist) :assumed))
+;; Assert that FORM is handled by the fopcompiler, then compile it.
+(defun assert-fopcompilable-and-compile-it (form)
+ ;; Since FOPCOMPILABLE-P now expands compiler-macros, and the macro for
+ ;; SOURCE-LOCATION expands to a literal structure, we end up calling
+ ;; CONSTANT-FOPCOMPILABLE-P which needs *COMPILE-OBJECT* to be bound.
+ (let ((sb-c::*compile-object*
+ (sb-fasl::make-fasl-output :stream (make-broadcast-stream)))
+ (sb-c::*lexenv* (sb-kernel:make-null-lexenv)))
+ (assert (sb-c::fopcompilable-p form))
(with-open-file (stream *tmp-filename*
:direction :output :if-exists :supersede)
(prin1 form stream))
- (multiple-value-bind (output warningp errorp)
- (compile-file *tmp-filename*)
- (when output
- (delete-file output))
- (assert (and warningp (not errorp))))))
+ (let (warning)
+ (handler-bind ((warning
+ (lambda (c)
+ (when (null warning)
+ (setq warning c)
+ (muffle-warning)))))
+ (multiple-value-bind (output warningp errorp)
+ (compile-file *tmp-filename*)
+ (when output
+ (delete-file output))
+ (if (and (not warningp) (not errorp))
+ ;; return muffled warning, which didn't count as a warning
+ warning))))))
+
+;; Ensure we can get a style-warning about undefined functions from FOPCOMPILE.
+(with-test (:name :fopcompiler-undefined-warning)
+ ;; Make sure some wiseacre didn't defconstant *FOO*
+ (assert (eq (sb-int:info :variable :kind '*foo*) :unknown))
+ ;; ... or define the I-DO-NOT-EXIST function.
+ (assert (eq (sb-int:info :function :where-from 'i-do-not-exist) :assumed))
+ (let ((w (assert-fopcompilable-and-compile-it
+ '(defvar *foo* (i-do-not-exist)))))
+ (assert (and (typep w 'sb-int:simple-style-warning)
+ (eql (search "undefined"
+ (simple-condition-format-control w)) 0)))))
+
+;; Ensure that FOPCOMPILE warns about deprecated variables.
+(with-test (:name :fopcompiler-deprecated-var-warning)
+ (assert (typep (assert-fopcompilable-and-compile-it
+ '(defvar *frob* (if *SHOW-ENTRY-POINT-DETAILS* 'yes 'no)))
+ 'sb-ext:deprecation-condition)))
(ignore-errors (delete-file *tmp-filename*))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|