X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1tran.lisp;h=71ec219008ad911eda250df5accfb3246b2ad3d5;hb=b7192afcef9bbfd3fe1a4e2bfe3c73f853d164d1;hp=45f95c6cee3331d95255297e6e5ad031797b67c8;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 45f95c6..71ec219 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -23,7 +23,7 @@ (declaim (hash-table *source-paths*)) (defvar *source-paths*) -;;; *CURRENT-COMPONENT* is the Component structure which we link +;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link ;;; blocks into as we generate them. This just serves to glue the ;;; emitted blocks together until local call analysis and flow graph ;;; canonicalization figure out what is really going on. We need to @@ -33,7 +33,7 @@ ;;; FIXME: It's confusing having one variable named *CURRENT-COMPONENT* ;;; and another named *COMPONENT-BEING-COMPILED*. (In CMU CL they ;;; were called *CURRENT-COMPONENT* and *COMPILE-COMPONENT* respectively, -;;; which also confusing.) +;;; which was also confusing.) (declaim (type (or component null) *current-component*)) (defvar *current-component*) @@ -48,12 +48,26 @@ to optimize code which uses those definitions? Setting this true gives non-ANSI, early-CMU-CL behavior. It can be useful for improving the efficiency of stable code.") + +(defvar *fun-names-in-this-file* nil) + +;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the +;;; insertion a (CATCH ...) around code to allow the debugger RETURN +;;; command to function. +(defvar *allow-debug-catch-tag* t) ;;;; namespace management utilities +(defun fun-lexically-notinline-p (name) + (let ((fun (lexenv-find name funs :test #'equal))) + ;; a declaration will trump a proclamation + (if (and fun (defined-fun-p fun)) + (eq (defined-fun-inlinep fun) :notinline) + (eq (info :function :inlinep name) :notinline)))) + ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. -(defun find-free-really-function (name) +(defun find-free-really-fun (name) (unless (info :function :kind name) (setf (info :function :kind name) :function) (setf (info :function :where-from name) :assumed)) @@ -67,47 +81,71 @@ ;; definedness at runtime, which is what matters. #-sb-xc-host (not (fboundp name))) (note-undefined-reference name :function)) - (make-global-var :kind :global-function - :name name - :type (if (or *derive-function-types* - (eq where :declared)) - (info :function :type name) - (specifier-type 'function)) - :where-from where))) - -;;; Return a SLOT-ACCESSOR structure usable for referencing the slot -;;; accessor NAME. CLASS is the structure class. -(defun find-structure-slot-accessor (class name) - (declare (type sb!xc:class class)) - (let* ((info (layout-info - (or (info :type :compiler-layout (sb!xc:class-name class)) - (class-layout class)))) - (accessor-name (if (listp name) (cadr name) name)) - (slot (find accessor-name (dd-slots info) - :key #'sb!kernel:dsd-accessor-name)) - (type (dd-name info)) - (slot-type (dsd-type slot))) - (unless slot - (error "can't find slot ~S" type)) - (make-slot-accessor - :name name - :type (specifier-type - (if (listp name) - `(function (,slot-type ,type) ,slot-type) - `(function (,type) ,slot-type))) - :for class - :slot slot))) - -;;; If NAME is already entered in *FREE-FUNCTIONS*, then return the -;;; value. Otherwise, make a new GLOBAL-VAR using information from the -;;; global environment and enter it in *FREE-FUNCTIONS*. If NAME names -;;; a macro or special form, then we error out using the supplied -;;; context which indicates what we were trying to do that demanded a -;;; function. -(defun find-free-function (name context) - (declare (string context)) - (declare (values global-var)) - (or (gethash name *free-functions*) + (make-global-var + :kind :global-function + :%source-name name + :type (if (or *derive-function-types* + (eq where :declared) + (and (member name *fun-names-in-this-file* :test #'equal) + (not (fun-lexically-notinline-p name)))) + (info :function :type name) + (specifier-type 'function)) + :where-from where))) + +;;; Has the *FREE-FUNS* entry FREE-FUN become invalid? +;;; +;;; In CMU CL, the answer was implicitly always true, so this +;;; predicate didn't exist. +;;; +;;; This predicate was added to fix bug 138 in SBCL. In some obscure +;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a +;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1 +;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka +;;; "dead") component. When this IR1 stuff was reused in a new +;;; component, under further obscure circumstances it could be used by +;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for +;;; *CURRENT-COMPONENT*. At that point things got all confused, since +;;; IR1 conversion was sending code to a component which had already +;;; been compiled and would never be compiled again. +(defun invalid-free-fun-p (free-fun) + ;; There might be other reasons that *FREE-FUN* entries could + ;; become invalid, but the only one we've been bitten by so far + ;; (sbcl-0.pre7.118) is this one: + (and (defined-fun-p free-fun) + (let ((functional (defined-fun-functional free-fun))) + (or (and functional + (eql (functional-kind functional) :deleted)) + (and (lambda-p functional) + (or + ;; (The main reason for this first test is to bail + ;; out early in cases where the LAMBDA-COMPONENT + ;; call in the second test would fail because links + ;; it needs are uninitialized or invalid.) + ;; + ;; If the BIND node for this LAMBDA is null, then + ;; according to the slot comments, the LAMBDA has + ;; been deleted or its call has been deleted. In + ;; that case, it seems rather questionable to reuse + ;; it, and certainly it shouldn't be necessary to + ;; reuse it, so we cheerfully declare it invalid. + (null (lambda-bind functional)) + ;; If this IR1 stuff belongs to a dead component, + ;; then we can't reuse it without getting into + ;; bizarre confusion. + (eql (component-info (lambda-component functional)) + :dead))))))) + +;;; If NAME already has a valid entry in *FREE-FUNS*, then return +;;; the value. Otherwise, make a new GLOBAL-VAR using information from +;;; the global environment and enter it in *FREE-FUNS*. If NAME +;;; names a macro or special form, then we error out using the +;;; supplied context which indicates what we were trying to do that +;;; demanded a function. +(declaim (ftype (sfunction (t string) global-var) find-free-fun)) +(defun find-free-fun (name context) + (or (let ((old-free-fun (gethash name *free-funs*))) + (and (not (invalid-free-fun-p old-free-fun)) + old-free-fun)) (ecase (info :function :kind name) ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged. (:macro @@ -117,85 +155,83 @@ name context)) ((:function nil) - (check-function-name name) - (note-if-setf-function-and-macro name) - (let ((expansion (info :function :inline-expansion name)) + (check-fun-name name) + (note-if-setf-fun-and-macro name) + (let ((expansion (fun-name-inline-expansion name)) (inlinep (info :function :inlinep name))) - (setf (gethash name *free-functions*) + (setf (gethash name *free-funs*) (if (or expansion inlinep) - (make-defined-function - :name name + (make-defined-fun + :%source-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)))))))))))) + :type (if (eq inlinep :notinline) + (specifier-type 'function) + (info :function :type name))) + (find-free-really-fun name)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. -(declaim (ftype (function (t string) leaf) find-lexically-apparent-function)) -(defun find-lexically-apparent-function (name context) - (let ((var (lexenv-find name functions :test #'equal))) +(declaim (ftype (sfunction (t string) leaf) find-lexically-apparent-fun)) +(defun find-lexically-apparent-fun (name context) + (let ((var (lexenv-find name funs :test #'equal))) (cond (var (unless (leaf-p var) (aver (and (consp var) (eq (car var) 'macro))) (compiler-error "found macro name ~S ~A" name context)) var) (t - (find-free-function name context))))) + (find-free-fun name context))))) ;;; Return the LEAF node for a global variable reference to NAME. If -;;; NAME is already entered in *FREE-VARIABLES*, then we just return -;;; the corresponding value. Otherwise, we make a new leaf using +;;; NAME is already entered in *FREE-VARS*, then we just return the +;;; corresponding value. Otherwise, we make a new leaf using ;;; information from the global environment and enter it in -;;; *FREE-VARIABLES*. If the variable is unknown, then we emit a -;;; warning. -(defun find-free-variable (name) - (declare (values (or leaf heap-alien-info))) +;;; *FREE-VARS*. If the variable is unknown, then we emit a warning. +(declaim (ftype (sfunction (t) (or leaf cons heap-alien-info)) find-free-var)) +(defun find-free-var (name) (unless (symbolp name) (compiler-error "Variable name is not a symbol: ~S." name)) - (or (gethash name *free-variables*) + (or (gethash name *free-vars*) (let ((kind (info :variable :kind name)) (type (info :variable :type name)) (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)))))))) + (setf (gethash name *free-vars*) + (case kind + (:alien + (info :variable :alien-info name)) + ;; FIXME: The return value in this case should really be + ;; of type SB!C::LEAF. I don't feel too badly about it, + ;; because the MACRO idiom is scattered throughout this + ;; file, but it should be cleaned up so we're not + ;; throwing random conses around. --njf 2002-03-23 + (:macro + (let ((expansion (info :variable :macro-expansion name)) + (type (type-specifier (info :variable :type name)))) + `(MACRO . (the ,type ,expansion)))) + (:constant + (let ((value (info :variable :constant-value name))) + (make-constant :value value + :%source-name name + :type (ctype-of value) + :where-from where-from))) + (t + (make-global-var :kind kind + :%source-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 ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. (eval-when (:compile-toplevel :load-toplevel :execute) - ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) + ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) ;; below. -- AL 20010227 - (defconstant list-to-hash-table-threshold 32)) + (def!constant list-to-hash-table-threshold 32)) (defun maybe-emit-make-load-forms (constant) (let ((things-processed nil) (count 0)) @@ -268,8 +304,7 @@ ;;; This function sets up the back link between the node and the ;;; continuation which continues at it. -#!-sb-fluid (declaim (inline prev-link)) -(defun prev-link (node cont) +(defun link-node-to-previous-continuation (node cont) (declare (type node node) (type continuation cont)) (aver (not (continuation-next cont))) (setf (continuation-next cont) node) @@ -280,12 +315,8 @@ ;;; the continuation has no block, then we make it be in the block ;;; that the node is in. If the continuation heads its block, we end ;;; our block and link it to that block. If the continuation is not -;;; currently used, then we set the derived-type for the continuation +;;; currently used, then we set the DERIVED-TYPE for the continuation ;;; to that of the node, so that a little type propagation gets done. -;;; -;;; We also deal with a bit of THE's semantics here: we weaken the -;;; assertion on CONT to be no stronger than the assertion on CONT in -;;; our scope. See the IR1-CONVERT method for THE. #!-sb-fluid (declaim (inline use-continuation)) (defun use-continuation (node cont) (declare (type node node) (type continuation cont)) @@ -313,30 +344,23 @@ (error "~S is already a predecessor of ~S." node-block block)) (push node-block (block-pred block)) (add-continuation-use node cont) - (unless (eq (continuation-asserted-type cont) *wild-type*) - (let ((new (values-type-union (continuation-asserted-type cont) - (or (lexenv-find cont type-restrictions) - *wild-type*)))) - (when (type/= new (continuation-asserted-type cont)) - (setf (continuation-asserted-type cont) new) - (reoptimize-continuation cont)))))) + (reoptimize-continuation cont))) ;;;; exported functions -;;; This function takes a form and the top-level form number for that +;;; This function takes a form and the top level form number for that ;;; form, and returns a lambda representing the translation of that ;;; form in the current global environment. The returned lambda is a -;;; top-level lambda that can be called to cause evaluation of the +;;; top level lambda that can be called to cause evaluation of the ;;; forms. This lambda is in the initial component. If FOR-VALUE is T, ;;; then the value of the form is returned from the function, ;;; otherwise NIL is returned. ;;; ;;; This function may have arbitrary effects on the global environment -;;; due to processing of PROCLAIMs and EVAL-WHENs. All syntax error -;;; checking is done, with erroneous forms being replaced by a proxy -;;; which signals an error if it is evaluated. Warnings about possibly -;;; inconsistent or illegal changes to the global environment will -;;; also be given. +;;; due to processing of EVAL-WHENs. All syntax error checking is +;;; done, with erroneous forms being replaced by a proxy which signals +;;; an error if it is evaluated. Warnings about possibly inconsistent +;;; or illegal changes to the global environment will also be given. ;;; ;;; We make the initial component and convert the form in a PROGN (and ;;; an optional NIL tacked on the end.) We then return the lambda. We @@ -347,7 +371,7 @@ ;;; The hashtables used to hold global namespace info must be ;;; reallocated elsewhere. Note also that *LEXENV* is not bound, so ;;; that local macro definitions can be introduced by enclosing code. -(defun ir1-top-level (form path for-value) +(defun ir1-toplevel (form path for-value) (declare (list path)) (let* ((*current-path* path) (component (make-empty-component)) @@ -355,24 +379,25 @@ (setf (component-name component) "initial component") (setf (component-kind component) :initial) (let* ((forms (if for-value `(,form) `(,form nil))) - (res (ir1-convert-lambda-body forms ()))) - (setf (leaf-name res) "top-level form") - (setf (functional-entry-function res) res) - (setf (functional-arg-documentation res) ()) - (setf (functional-kind res) :top-level) + (res (ir1-convert-lambda-body + forms () + :debug-name (debug-namify "top level form ~S" form)))) + (setf (functional-entry-fun res) res + (functional-arg-documentation res) () + (functional-kind res) :toplevel) res))) ;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the ;;; form number to associate with a source path. This should be bound ;;; to an initial value of 0 before the processing of each truly -;;; top-level form. +;;; top level form. (declaim (type index *current-form-number*)) (defvar *current-form-number*) ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to -;;; find the paths in, and TLF-NUM is the top-level form number of the -;;; truly top-level form. +;;; find the paths in, and TLF-NUM is the top level form number of the +;;; truly top level form. ;;; ;;; This gets a bit interesting when the source code is circular. This ;;; can (reasonably?) happen in the case of circular list constants. @@ -406,16 +431,19 @@ ;;;; IR1-CONVERT, macroexpansion and special form dispatching +(declaim (ftype (sfunction (continuation continuation t) (values)) + ir1-convert)) (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws ;; out of the body and converts a proxy form instead. (ir1-error-bailout ((start cont form &optional - (proxy ``(error "execution of a form compiled with errors:~% ~S" - ',,form))) + (proxy ``(error 'simple-program-error + :format-control "execution of a form compiled with errors:~% ~S" + :format-arguments (list ',,form)))) &body body) - (let ((skip (gensym "SKIP"))) + (with-unique-names (skip) `(block ,skip (catch 'ir1-error-abort (let ((*compiler-error-bailout* @@ -435,44 +463,51 @@ ;; the creation using backquote of forms that contain leaf ;; references, without having to introduce dummy names into the ;; namespace. - (declaim (ftype (function (continuation continuation t) (values)) ir1-convert)) (defun ir1-convert (start cont form) (ir1-error-bailout (start cont form) (let ((*current-path* (or (gethash form *source-paths*) (cons form *current-path*)))) (if (atom form) (cond ((and (symbolp form) (not (keywordp form))) - (ir1-convert-variable start cont form)) + (ir1-convert-var start cont form)) ((leaf-p form) (reference-leaf start cont form)) (t (reference-constant start cont form))) - (let ((fun (car form))) - (cond - ((symbolp fun) - (let ((lexical-def (lexenv-find fun functions))) - (typecase lexical-def - (null (ir1-convert-global-functoid start cont form)) - (functional - (ir1-convert-local-combination start - cont - form - lexical-def)) - (global-var - (ir1-convert-srctran start cont lexical-def form)) + (let ((opname (car form))) + (cond ((or (symbolp opname) (leaf-p opname)) + (let ((lexical-def (if (leaf-p opname) + opname + (lexenv-find opname funs)))) + (typecase lexical-def + (null (ir1-convert-global-functoid start cont form)) + (functional + (ir1-convert-local-combination start + cont + form + lexical-def)) + (global-var + (ir1-convert-srctran start cont lexical-def form)) + (t + (aver (and (consp lexical-def) + (eq (car lexical-def) 'macro))) + (ir1-convert start cont + (careful-expand-macro (cdr lexical-def) + form)))))) + ((or (atom opname) (not (eq (car opname) 'lambda))) + (compiler-error "illegal function call")) (t - (aver (and (consp lexical-def) - (eq (car lexical-def) 'macro))) - (ir1-convert start cont - (careful-expand-macro (cdr lexical-def) - form)))))) - ((or (atom fun) (not (eq (car fun) 'lambda))) - (compiler-error "illegal function call")) - (t - (ir1-convert-combination start - cont - form - (ir1-convert-lambda fun)))))))) + ;; implicitly (LAMBDA ..) because the LAMBDA + ;; expression is the CAR of an executed form + (ir1-convert-combination start + cont + form + (ir1-convert-lambda + opname + :debug-name (debug-namify + "LAMBDA CAR ~S" + opname) + :allow-debug-catch-tag t)))))))) (values)) ;; Generate a reference to a manifest constant, creating a new leaf @@ -483,23 +518,38 @@ (declare (type continuation start cont) (inline find-constant)) (ir1-error-bailout - (start cont value - '(error "attempt to reference undumpable constant")) + (start cont value '(error "attempt to reference undumpable constant")) (when (producing-fasl-file) (maybe-emit-make-load-forms value)) (let* ((leaf (find-constant value)) - (res (make-ref (leaf-type leaf) leaf))) + (res (make-ref leaf))) (push res (leaf-refs leaf)) - (prev-link res start) + (link-node-to-previous-continuation res start) (use-continuation res cont))) (values))) -;;; Add Fun to the COMPONENT-REANALYZE-FUNCTIONS. Fun is returned. - (defun maybe-reanalyze-function (fun) - (declare (type functional fun)) - (when (typep fun '(or optional-dispatch clambda)) - (pushnew fun (component-reanalyze-functions *current-component*))) - fun) +;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's +;;; some trivial type for which reanalysis is a trivial no-op, or +;;; unless it doesn't belong in this component at all. +;;; +;;; FUNCTIONAL is returned. +(defun maybe-reanalyze-functional (functional) + + (aver (not (eql (functional-kind functional) :deleted))) ; bug 148 + (aver-live-component *current-component*) + + ;; When FUNCTIONAL is of a type for which reanalysis isn't a trivial + ;; no-op + (when (typep functional '(or optional-dispatch clambda)) + + ;; When FUNCTIONAL knows its component + (when (lambda-p functional) + (aver (eql (lambda-component functional) *current-component*))) + + (pushnew functional + (component-reanalyze-functionals *current-component*))) + + functional) ;;; Generate a REF node for LEAF, frobbing the LEAF structure as ;;; needed. If LEAF represents a defined function which has already @@ -507,62 +557,90 @@ ;;; 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) - :notinline)) - (let ((fun (defined-function-functional leaf))) - (when (and fun (not (functional-kind fun))) - (maybe-reanalyze-function fun)))) - leaf)) - (res (make-ref (or (lexenv-find leaf type-restrictions) - (leaf-type leaf)) - leaf))) - (push res (leaf-refs leaf)) + (when (functional-p leaf) + (assure-functional-live-p leaf)) + (let* ((type (lexenv-find leaf type-restrictions)) + (leaf (or (and (defined-fun-p leaf) + (not (eq (defined-fun-inlinep leaf) + :notinline)) + (let ((functional (defined-fun-functional leaf))) + (when (and functional + (not (functional-kind functional))) + (maybe-reanalyze-functional functional)))) + (when (and (lambda-p leaf) + (memq (functional-kind leaf) + '(nil :optional))) + (maybe-reanalyze-functional leaf)) + leaf)) + (ref (make-ref leaf))) + (push ref (leaf-refs leaf)) (setf (leaf-ever-used leaf) t) - (prev-link res start) - (use-continuation res cont))) + (link-node-to-previous-continuation ref start) + (cond (type (let* ((ref-cont (make-continuation)) + (cast (make-cast ref-cont + (make-single-value-type type) + (lexenv-policy *lexenv*)))) + (setf (continuation-dest ref-cont) cast) + (use-continuation ref ref-cont) + (link-node-to-previous-continuation cast ref-cont) + (use-continuation cast cont))) + (t (use-continuation ref cont))))) ;;; Convert a reference to a symbolic constant or variable. If the -;;; symbol is entered in the LEXENV-VARIABLES we use that definition, +;;; symbol is entered in the LEXENV-VARS we use that definition, ;;; otherwise we find the current global definition. This is also -;;; where we pick off symbol macro and Alien variable references. -(defun ir1-convert-variable (start cont name) +;;; where we pick off symbol macro and alien variable references. +(defun ir1-convert-var (start cont name) (declare (type continuation start cont) (symbol name)) - (let ((var (or (lexenv-find name variables) (find-free-variable name)))) + (let ((var (or (lexenv-find name vars) (find-free-var name)))) (etypecase var (leaf - (when (and (lambda-var-p var) (lambda-var-ignorep var)) - ;; (ANSI's specification for the IGNORE declaration requires - ;; that this be a STYLE-WARNING, not a full WARNING.) - (compiler-style-warning "reading an ignored variable: ~S" name)) + (when (lambda-var-p var) + (let ((home (continuation-home-lambda-or-null start))) + (when home + (pushnew var (lambda-calls-or-closes home)))) + (when (lambda-var-ignorep var) + ;; (ANSI's specification for the IGNORE declaration requires + ;; that this be a STYLE-WARNING, not a full WARNING.) + (compiler-style-warn "reading an ignored variable: ~S" name))) (reference-leaf start cont var)) (cons (aver (eq (car var) 'MACRO)) + ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 (ir1-convert start cont (cdr var))) (heap-alien-info (ir1-convert start cont `(%heap-alien ',var))))) (values)) ;;; Convert anything that looks like a special form, global function -;;; or macro call. +;;; or compiler-macro call. (defun ir1-convert-global-functoid (start cont form) (declare (type continuation start cont) (list form)) - (let* ((fun (first form)) - (translator (info :function :ir1-convert fun)) - (cmacro (info :function :compiler-macro-function fun))) - (cond (translator (funcall translator start cont form)) - ((and cmacro - (not (eq (info :function :inlinep fun) - :notinline))) - (let ((res (careful-expand-macro cmacro form))) + (let* ((fun-name (first form)) + (translator (info :function :ir1-convert fun-name)) + (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*))) + (cond (translator + (when cmacro-fun + (compiler-warn "ignoring compiler macro for special form")) + (funcall translator start cont form)) + ((and cmacro-fun + ;; gotcha: If you look up the DEFINE-COMPILER-MACRO + ;; macro in the ANSI spec, you might think that + ;; suppressing compiler-macro expansion when NOTINLINE + ;; is some pre-ANSI hack. However, if you look up the + ;; NOTINLINE declaration, you'll find that ANSI + ;; requires this behavior after all. + (not (eq (info :function :inlinep fun-name) :notinline))) + (let ((res (careful-expand-macro cmacro-fun form))) (if (eq res form) - (ir1-convert-global-functoid-no-cmacro start cont form fun) + (ir1-convert-global-functoid-no-cmacro + start cont form fun-name) (ir1-convert start cont res)))) (t - (ir1-convert-global-functoid-no-cmacro start cont form fun))))) + (ir1-convert-global-functoid-no-cmacro start cont form fun-name))))) -;;; Handle the case of where the call was not a compiler macro, or was a -;;; compiler macro and passed. +;;; Handle the case of where the call was not a compiler macro, or was +;;; a compiler macro and passed. (defun ir1-convert-global-functoid-no-cmacro (start cont form fun) (declare (type continuation start cont) (list form)) ;; FIXME: Couldn't all the INFO calls here be converted into @@ -576,78 +654,86 @@ (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-fun fun "shouldn't happen! (no-cmacro)") + form)))) (defun muffle-warning-or-die () (muffle-warning) - (error "internal error -- no MUFFLE-WARNING restart")) + (bug "no MUFFLE-WARNING restart")) ;;; 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 ((style-warning (lambda (c) + (compiler-style-warn + "~@<~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 + #+(and cmu sb-xc-host) + (warning (lambda (c) + (compiler-notify + "~@<~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))) + #-(and cmu sb-xc-host) + (warning (lambda (c) + (compiler-warn "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint 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 ;;; Convert a bunch of forms, discarding all the values except the ;;; last. If there aren't any forms, then translate a NIL. -(declaim (ftype (function (continuation continuation list) (values)) +(declaim (ftype (sfunction (continuation continuation list) (values)) ir1-convert-progn-body)) (defun ir1-convert-progn-body (start cont body) (if (endp body) @@ -661,30 +747,30 @@ (return)) (let ((this-cont (make-continuation))) (ir1-convert this-start this-cont form) - (setq this-start this-cont forms (cdr forms))))))) + (setq this-start this-cont + forms (cdr forms))))))) (values)) ;;;; converting combinations -;;; Convert a function call where the function (Fun) is a Leaf. We -;;; return the Combination node so that we can poke at it if we want to. -(declaim (ftype (function (continuation continuation list leaf) combination) +;;; Convert a function call where the function FUN is a LEAF. FORM is +;;; the source for the call. We return the COMBINATION node so that +;;; the caller can poke at it if it wants to. +(declaim (ftype (sfunction (continuation continuation list leaf) combination) ir1-convert-combination)) (defun ir1-convert-combination (start cont form fun) (let ((fun-cont (make-continuation))) - (reference-leaf start fun-cont fun) + (ir1-convert start fun-cont `(the (or function symbol) ,fun)) (ir1-convert-combination-args fun-cont cont (cdr form)))) -;;; Convert the arguments to a call and make the Combination node. Fun-Cont -;;; is the continuation which yields the function to call. Form is the source -;;; for the call. Args is the list of arguments for the call, which defaults -;;; to the cdr of source. We return the Combination node. +;;; Convert the arguments to a call and make the COMBINATION +;;; node. FUN-CONT is the continuation which yields the function to +;;; call. ARGS is the list of arguments for the call, which defaults +;;; to the cdr of source. We return the COMBINATION node. (defun ir1-convert-combination-args (fun-cont cont args) (declare (type continuation fun-cont cont) (list args)) (let ((node (make-combination fun-cont))) (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args) @@ -692,7 +778,7 @@ (ir1-convert this-start this-cont arg) (setq this-start this-cont) (arg-conts this-cont))) - (prev-link node this-start) + (link-node-to-previous-continuation node this-start) (use-continuation node cont) (setf (combination-args node) (arg-conts)))) node)) @@ -704,17 +790,19 @@ ;;; 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)))) - (if transform - (multiple-value-bind (result pass) (funcall transform form) - (if pass - (ir1-convert-maybe-predicate start cont form var) + (let ((transform (info :function + :source-transform + (leaf-source-name var)))) + (if transform + (multiple-value-bind (result pass) (funcall transform form) + (if pass + (ir1-convert-maybe-predicate start cont form var) (ir1-convert start cont result))) - (ir1-convert-maybe-predicate start cont form var)))))) + (ir1-convert-maybe-predicate start cont form var)))))) ;;; If the function has the PREDICATE attribute, and the CONT's DEST ;;; isn't an IF, then we convert (IF