X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=f3996cf7a6e8c7bba1ef596bca947122515c9a09;hb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;hp=6b332e42fa8792f1b0fe79233008635a66b02a83;hpb=be9eb6c67b5f43a095c3de17bea945c309d662e4;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 6b332e4..f3996cf 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -117,31 +117,19 @@ name context)) ((:function nil) - (check-function-name name) + (check-fun-name name) (note-if-setf-function-and-macro name) - (let ((expansion (info :function :inline-expansion name)) + (let ((expansion (fun-name-inline-expansion name)) (inlinep (info :function :inlinep name))) (setf (gethash name *free-functions*) (if (or expansion inlinep) - (make-defined-function + (make-defined-fun :name name :inline-expansion expansion :inlinep inlinep :where-from (info :function :where-from name) :type (info :function :type name)) - (let ((info (info :function :accessor-for name))) - (etypecase info - (null - (find-free-really-function name)) - (sb!xc:structure-class - (find-structure-slot-accessor info name)) - (sb!xc:class - (if (typep (layout-info (info :type :compiler-layout - (sb!xc:class-name - info))) - 'defstruct-description) - (find-structure-slot-accessor info name) - (find-free-really-function name)))))))))))) + (find-free-really-function name)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. @@ -172,21 +160,21 @@ (where-from (info :variable :where-from name))) (when (and (eq where-from :assumed) (eq kind :global)) (note-undefined-reference name :variable)) - (setf (gethash name *free-variables*) - (if (eq kind :alien) - (info :variable :alien-info name) - (multiple-value-bind (val valp) - (info :variable :constant-value name) - (if (and (eq kind :constant) valp) - (make-constant :value val - :name name - :type (ctype-of val) - :where-from where-from) - (make-global-var :kind kind - :name name - :type type - :where-from where-from)))))))) + (case kind + (:alien + (info :variable :alien-info name)) + (:constant + (let ((value (info :variable :constant-value name))) + (make-constant :value value + :name name + :type (ctype-of value) + :where-from where-from))) + (t + (make-global-var :kind kind + :name name + :type type + :where-from where-from))))))) ;;; Grovel over CONSTANT checking for any sub-parts that need to be ;;; processed with MAKE-LOAD-FORM. We have to be careful, because @@ -507,10 +495,10 @@ ;;; functional instead. (defun reference-leaf (start cont leaf) (declare (type continuation start cont) (type leaf leaf)) - (let* ((leaf (or (and (defined-function-p leaf) - (not (eq (defined-function-inlinep leaf) + (let* ((leaf (or (and (defined-fun-p leaf) + (not (eq (defined-fun-inlinep leaf) :notinline)) - (let ((fun (defined-function-functional leaf))) + (let ((fun (defined-fun-functional leaf))) (when (and fun (not (functional-kind fun))) (maybe-reanalyze-function fun)))) leaf)) @@ -576,7 +564,11 @@ (careful-expand-macro (info :function :macro-function fun) form))) ((nil :function) - (ir1-convert-srctran start cont (find-free-function fun "Eh?") form)))) + (ir1-convert-srctran start + cont + (find-free-function fun + "shouldn't happen! (no-cmacro)") + form)))) (defun muffle-warning-or-die () (muffle-warning) @@ -585,63 +577,78 @@ ;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping ;;; errors which occur during the macroexpansion. (defun careful-expand-macro (fun form) - (handler-bind (;; When cross-compiling, we can get style warnings - ;; about e.g. undefined functions. An unhandled - ;; CL:STYLE-WARNING (as opposed to a - ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be - ;; set on the return from #'SB!XC:COMPILE-FILE, which - ;; would falsely indicate an error sufficiently - ;; serious that we should stop the build process. To - ;; avoid this, we translate CL:STYLE-WARNING - ;; conditions from the host Common Lisp into - ;; cross-compiler SB!C::COMPILER-NOTE calls. (It - ;; might be cleaner to just make Python use - ;; CL:STYLE-WARNING internally, so that the - ;; significance of any host Common Lisp - ;; CL:STYLE-WARNINGs is understood automatically. But - ;; for now I'm not motivated to do this. -- WHN - ;; 19990412) - (style-warning (lambda (c) - (compiler-note "(during macroexpansion)~%~A" - c) - (muffle-warning-or-die))) - ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for - ;; Debian Linux, anyway) raises a CL:WARNING - ;; condition (not a CL:STYLE-WARNING) for undefined - ;; symbols when converting interpreted functions, - ;; causing COMPILE-FILE to think the file has a real - ;; problem, causing COMPILE-FILE to return FAILURE-P - ;; set (not just WARNINGS-P set). Since undefined - ;; symbol warnings are often harmless forward - ;; references, and since it'd be inordinately painful - ;; to try to eliminate all such forward references, - ;; these warnings are basically unavoidable. Thus, we - ;; need to coerce the system to work through them, - ;; and this code does so, by crudely suppressing all - ;; warnings in cross-compilation macroexpansion. -- - ;; WHN 19990412 - #+cmu - (warning (lambda (c) - (compiler-note - "(during macroexpansion)~%~ - ~A~%~ - (KLUDGE: That was a non-STYLE WARNING.~%~ - Ordinarily that would cause compilation to~%~ - fail. However, since we're running under~%~ - CMU CL, and since CMU CL emits non-STYLE~%~ - warnings for safe, hard-to-fix things (e.g.~%~ - references to not-yet-defined functions)~%~ - we're going to have to ignore it and proceed~%~ - anyway. Hopefully we're not ignoring anything~%~ - horrible here..)~%" - c) - (muffle-warning-or-die))) - (error (lambda (c) - (compiler-error "(during macroexpansion)~%~A" c)))) - (funcall sb!xc:*macroexpand-hook* - fun - form - *lexenv*))) + (let (;; a hint I (WHN) wish I'd known earlier + (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)")) + (flet (;; Return a string to use as a prefix in error reporting, + ;; telling something about which form caused the problem. + (wherestring () + (let ((*print-pretty* nil) + ;; We rely on the printer to abbreviate FORM. + (*print-length* 3) + (*print-level* 1)) + (format + nil + #-sb-xc-host "(in macroexpansion of ~S)" + ;; longer message to avoid ambiguity "Was it the xc host + ;; or the cross-compiler which encountered the problem?" + #+sb-xc-host "(in cross-compiler macroexpansion of ~S)" + form)))) + (handler-bind (;; When cross-compiling, we can get style warnings + ;; about e.g. undefined functions. An unhandled + ;; CL:STYLE-WARNING (as opposed to a + ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be + ;; set on the return from #'SB!XC:COMPILE-FILE, which + ;; would falsely indicate an error sufficiently + ;; serious that we should stop the build process. To + ;; avoid this, we translate CL:STYLE-WARNING + ;; conditions from the host Common Lisp into + ;; cross-compiler SB!C::COMPILER-NOTE calls. (It + ;; might be cleaner to just make Python use + ;; CL:STYLE-WARNING internally, so that the + ;; significance of any host Common Lisp + ;; CL:STYLE-WARNINGs is understood automatically. But + ;; for now I'm not motivated to do this. -- WHN + ;; 19990412) + (style-warning (lambda (c) + (compiler-note "~@<~A~:@_~A~:@_~A~:>" + (wherestring) hint c) + (muffle-warning-or-die))) + ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for + ;; Debian Linux, anyway) raises a CL:WARNING + ;; condition (not a CL:STYLE-WARNING) for undefined + ;; symbols when converting interpreted functions, + ;; causing COMPILE-FILE to think the file has a real + ;; problem, causing COMPILE-FILE to return FAILURE-P + ;; set (not just WARNINGS-P set). Since undefined + ;; symbol warnings are often harmless forward + ;; references, and since it'd be inordinately painful + ;; to try to eliminate all such forward references, + ;; these warnings are basically unavoidable. Thus, we + ;; need to coerce the system to work through them, + ;; and this code does so, by crudely suppressing all + ;; warnings in cross-compilation macroexpansion. -- + ;; WHN 19990412 + #+cmu + (warning (lambda (c) + (compiler-note + "~@<~A~:@_~ + ~A~:@_~ + ~@<(KLUDGE: That was a non-STYLE WARNING. ~ + Ordinarily that would cause compilation to ~ + fail. However, since we're running under ~ + CMU CL, and since CMU CL emits non-STYLE ~ + warnings for safe, hard-to-fix things (e.g. ~ + references to not-yet-defined functions) ~ + we're going to have to ignore it and ~ + proceed anyway. Hopefully we're not ~ + ignoring anything horrible here..)~:@>~:>" + (wherestring) + c) + (muffle-warning-or-die))) + (error (lambda (c) + (compiler-error "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint c)))) + (funcall sb!xc:*macroexpand-hook* fun form *lexenv*))))) ;;;; conversion utilities @@ -704,8 +711,8 @@ ;;; go to ok-combination conversion. (defun ir1-convert-srctran (start cont var form) (declare (type continuation start cont) (type global-var var)) - (let ((inlinep (when (defined-function-p var) - (defined-function-inlinep var)))) + (let ((inlinep (when (defined-fun-p var) + (defined-fun-inlinep var)))) (if (eq inlinep :notinline) (ir1-convert-combination start cont form var) (let ((transform (info :function :source-transform (leaf-name var)))) @@ -893,19 +900,19 @@ (make-lexenv :default res :variables (new-venv)) res))) -;;; Return a DEFINED-FUNCTION which copies a global-var but for its inlinep. +;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP. (defun make-new-inlinep (var inlinep) (declare (type global-var var) (type inlinep inlinep)) - (let ((res (make-defined-function + (let ((res (make-defined-fun :name (leaf-name var) :where-from (leaf-where-from var) :type (leaf-type var) :inlinep inlinep))) - (when (defined-function-p var) - (setf (defined-function-inline-expansion res) - (defined-function-inline-expansion var)) - (setf (defined-function-functional res) - (defined-function-functional var))) + (when (defined-fun-p var) + (setf (defined-fun-inline-expansion res) + (defined-fun-inline-expansion var)) + (setf (defined-fun-functional res) + (defined-fun-functional var))) res)) ;;; Parse an inline/notinline declaration. If it's a local function we're @@ -1832,28 +1839,28 @@ :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) name)))) -;;; Get a DEFINED-FUNCTION object for a function we are about to +;;; Get a DEFINED-FUN object for a function we are about to ;;; define. If the function has been forward referenced, then ;;; substitute for the previous references. -(defun get-defined-function (name) - (let* ((name (proclaim-as-function-name name)) - (found (find-free-function name "Eh?"))) +(defun get-defined-fun (name) + (proclaim-as-fun-name name) + (let ((found (find-free-function name "shouldn't happen! (defined-fun)"))) (note-name-defined name :function) - (cond ((not (defined-function-p found)) + (cond ((not (defined-fun-p found)) (aver (not (info :function :inlinep name))) (let* ((where-from (leaf-where-from found)) - (res (make-defined-function + (res (make-defined-fun :name name :where-from (if (eq where-from :declared) :declared :defined) :type (leaf-type found)))) (substitute-leaf res found) (setf (gethash name *free-functions*) res))) - ;; If *FREE-FUNCTIONS* has a previously converted definition for this - ;; name, then blow it away and try again. - ((defined-function-functional found) + ;; If *FREE-FUNCTIONS* has a previously converted definition + ;; for this name, then blow it away and try again. + ((defined-fun-functional found) (remhash name *free-functions*) - (get-defined-function name)) + (get-defined-fun name)) (t found)))) ;;; Check a new global function definition for consistency with @@ -1899,19 +1906,19 @@ ;;; expansion. This prevents recursive inline expansion of ;;; opportunistic pseudo-inlines. (defun ir1-convert-lambda-for-defun (lambda var expansion converter) - (declare (cons lambda) (function converter) (type defined-function var)) - (let ((var-expansion (defined-function-inline-expansion var))) - (unless (eq (defined-function-inlinep var) :inline) - (setf (defined-function-inline-expansion var) nil)) + (declare (cons lambda) (function converter) (type defined-fun var)) + (let ((var-expansion (defined-fun-inline-expansion var))) + (unless (eq (defined-fun-inlinep var) :inline) + (setf (defined-fun-inline-expansion var) nil)) (let* ((name (leaf-name var)) (fun (funcall converter lambda name)) (function-info (info :function :info name))) - (setf (functional-inlinep fun) (defined-function-inlinep var)) + (setf (functional-inlinep fun) (defined-fun-inlinep var)) (assert-new-definition var fun) - (setf (defined-function-inline-expansion var) var-expansion) + (setf (defined-fun-inline-expansion var) var-expansion) ;; If definitely not an interpreter stub, then substitute for any ;; old references. - (unless (or (eq (defined-function-inlinep var) :notinline) + (unless (or (eq (defined-fun-inlinep var) :notinline) (not *block-compile*) (and function-info (or (function-info-transforms function-info) @@ -1920,7 +1927,7 @@ (substitute-leaf fun var) ;; If in a simple environment, then we can allow backward ;; references to this function from following top-level forms. - (when expansion (setf (defined-function-functional var) fun))) + (when expansion (setf (defined-fun-functional var) fun))) fun))) ;;; the even-at-compile-time part of DEFUN @@ -1929,31 +1936,31 @@ ;;; no inline expansion. (defun %compiler-defun (name lambda-with-lexenv) - (let ((defined-function nil)) ; will be set below if we're in the compiler + (let ((defined-fun nil)) ; will be set below if we're in the compiler - ;; when in the compiler - (when (boundp '*lexenv*) + (when (boundp '*lexenv*) ; when in the compiler (when sb!xc:*compile-print* (compiler-mumble "~&; recognizing DEFUN ~S~%" name)) (remhash name *free-functions*) - (setf defined-function (get-defined-function name))) + (setf defined-fun (get-defined-fun name))) - (become-defined-function-name name) + (become-defined-fun-name name) (cond (lambda-with-lexenv - (setf (info :function :inline-expansion name) lambda-with-lexenv) - (when defined-function - (setf (defined-function-inline-expansion defined-function) + (setf (info :function :inline-expansion-designator name) + lambda-with-lexenv) + (when defined-fun + (setf (defined-fun-inline-expansion defined-fun) lambda-with-lexenv))) (t - (clear-info :function :inline-expansion name))) + (clear-info :function :inline-expansion-designator name))) ;; old CMU CL comment: ;; If there is a type from a previous definition, blast it, ;; since it is obsolete. - (when (and defined-function - (eq (leaf-where-from defined-function) :defined)) - (setf (leaf-type defined-function) + (when (and defined-fun + (eq (leaf-where-from defined-fun) :defined)) + (setf (leaf-type defined-fun) ;; FIXME: If this is a block compilation thing, shouldn't ;; we be setting the type to the full derived type for the ;; definition, instead of this most general function type? @@ -1963,15 +1970,15 @@ ;;;; hacking function names -;;; This is like LAMBDA, except the result is tweaked so that -;;; %FUNCTION-NAME can extract a name. (Also possibly the name could -;;; also be used at compile time to emit more-informative name-based -;;; compiler diagnostic messages as well.) +;;; This is like LAMBDA, except the result is tweaked so that FUN-NAME +;;; can extract a name. (Also possibly the name could also be used at +;;; compile time to emit more-informative name-based compiler +;;; diagnostic messages as well.) (defmacro-mundanely named-lambda (name args &body body) ;; FIXME: For now, in this stub version, we just discard the name. A ;; non-stub version might use either macro-level LOAD-TIME-VALUE ;; hackery or customized IR1-transform level magic to actually put ;; the name in place. - (aver (legal-function-name-p name)) + (aver (legal-fun-name-p name)) `(lambda ,args ,@body))