X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=3d76cc5289144580870f7343de6dcdff13cb729a;hb=05525d3a5906d7a89fcb689c26177732493c40ce;hp=daa641ff777aa5fb758920096b2c1c381be142ab;hpb=f1efc390c46d7b0054b504981b36baf928259ab6;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index daa641f..3d76cc5 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -48,12 +48,17 @@ 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.") + +;;; *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 ;;; 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)) @@ -75,36 +80,13 @@ (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 - :%source-name name - :type (specifier-type - (if (listp name) - `(function (,slot-type ,type) ,slot-type) - `(function (,type) ,slot-type))) - :for class - :slot slot))) - -;;; Has the *FREE-FUNCTIONS* entry FREE-FUNCTION become invalid? +;;; 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-FUNCTIONS* to contain a +;;; 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 @@ -113,43 +95,45 @@ ;;; *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-function-p (free-function) - ;; There might be other reasons that *FREE-FUNCTION* entries could +(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-function) - (let ((functional (defined-fun-functional free-function))) - (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-FUNCTIONS*, then return + (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-FUNCTIONS*. If NAME +;;; 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. -(defun find-free-function (name context) - (declare (string context)) - (declare (values global-var)) - (or (let ((old-free-function (gethash name *free-functions*))) - (and (not (invalid-free-function-p old-free-function)) - old-free-function)) +(declaim (ftype (function (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 @@ -160,10 +144,10 @@ context)) ((:function nil) (check-fun-name name) - (note-if-setf-function-and-macro 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-fun :%source-name name @@ -171,41 +155,49 @@ :inlinep inlinep :where-from (info :function :where-from name) :type (info :function :type name)) - (find-free-really-function 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 (function (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 (function (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*) + (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 @@ -223,9 +215,9 @@ ;;; 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)) @@ -311,10 +303,6 @@ ;;; our block and link it to that block. If the continuation is not ;;; 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)) @@ -342,13 +330,7 @@ (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 @@ -441,10 +423,11 @@ 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* @@ -471,14 +454,16 @@ (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 ((opname (car form))) - (cond ((symbolp opname) - (let ((lexical-def (lexenv-find opname functions))) + (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 @@ -497,7 +482,7 @@ ((or (atom opname) (not (eq (car opname) 'lambda))) (compiler-error "illegal function call")) (t - ;; implicitly #'(LAMBDA ..) because the LAMBDA + ;; implicitly (LAMBDA ..) because the LAMBDA ;; expression is the CAR of an executed form (ir1-convert-combination start cont @@ -506,7 +491,8 @@ opname :debug-name (debug-namify "LAMBDA CAR ~S" - opname))))))))) + opname) + :allow-debug-catch-tag t)))))))) (values)) ;; Generate a reference to a manifest constant, creating a new leaf @@ -521,32 +507,34 @@ (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)) (link-node-to-previous-continuation res start) (use-continuation res cont))) (values))) -;;; Add FUN to the COMPONENT-REANALYZE-FUNS, 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. +;;; 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. ;;; -;;; FUN is returned. -(defun maybe-reanalyze-fun (fun) - (declare (type functional fun)) +;;; FUNCTIONAL is returned. +(defun maybe-reanalyze-functional (functional) + (aver (not (eql (functional-kind functional) :deleted))) ; bug 148 (aver-live-component *current-component*) - ;; When FUN is of a type for which reanalysis isn't a trivial no-op - (when (typep fun '(or optional-dispatch clambda)) + ;; When FUNCTIONAL is of a type for which reanalysis isn't a trivial + ;; no-op + (when (typep functional '(or optional-dispatch clambda)) - ;; When FUN knows its component - (when (lambda-p fun) - (aver (eql (lambda-component fun) *current-component*))) + ;; When FUNCTIONAL knows its component + (when (lambda-p functional) + (aver (eql (lambda-component functional) *current-component*))) - (pushnew fun (component-reanalyze-funs *current-component*))) + (pushnew functional + (component-reanalyze-functionals *current-component*))) - fun) + functional) ;;; Generate a REF node for LEAF, frobbing the LEAF structure as ;;; needed. If LEAF represents a defined function which has already @@ -554,28 +542,36 @@ ;;; functional instead. (defun reference-leaf (start cont leaf) (declare (type continuation start cont) (type leaf leaf)) - (let* ((leaf (or (and (defined-fun-p leaf) - (not (eq (defined-fun-inlinep leaf) - :notinline)) - (let ((fun (defined-fun-functional leaf))) - (when (and fun (not (functional-kind fun))) - (maybe-reanalyze-fun fun)))) - leaf)) - (res (make-ref (or (lexenv-find leaf type-restrictions) - (leaf-type leaf)) - leaf))) - (push res (leaf-refs 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)))) + leaf)) + (ref (make-ref leaf))) + (push ref (leaf-refs leaf)) (setf (leaf-ever-used leaf) t) - (link-node-to-previous-continuation 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) +(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 (lambda-var-p var) @@ -585,32 +581,42 @@ (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-warning "reading an ignored variable: ~S" name))) + (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. @@ -629,13 +635,12 @@ ((nil :function) (ir1-convert-srctran start cont - (find-free-function fun - "shouldn't happen! (no-cmacro)") + (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. @@ -656,27 +661,12 @@ ;; 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 + (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, @@ -691,7 +681,7 @@ ;; and this code does so, by crudely suppressing all ;; warnings in cross-compilation macroexpansion. -- ;; WHN 19990412 - #+cmu + #+(and cmu sb-xc-host) (warning (lambda (c) (compiler-note "~@<~A~:@_~ @@ -708,6 +698,11 @@ (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)))) @@ -737,27 +732,24 @@ ;;;; converting combinations -;;; Convert a function call where the function (i.e. the FUN argument) -;;; is a LEAF. We return the COMBINATION node so that the caller can -;;; poke at it if it wants to. +;;; 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 (function (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) @@ -801,7 +793,7 @@ (declare (type continuation start cont) (list form) (type global-var var)) (let ((info (info :function :info (leaf-source-name var)))) (if (and info - (ir1-attributep (function-info-attributes info) predicate) + (ir1-attributep (fun-info-attributes info) predicate) (not (if-p (continuation-dest cont)))) (ir1-convert start cont `(if ,form t nil)) (ir1-convert-combination-checking-type start cont form var)))) @@ -826,20 +818,45 @@ (fun-cont (basic-combination-fun node)) (type (leaf-type var))) (when (validate-call-type node type t) - (setf (continuation-%derived-type fun-cont) type) - (setf (continuation-reoptimize fun-cont) nil) - (setf (continuation-%type-check fun-cont) nil))) + (setf (continuation-%derived-type fun-cont) + (make-single-value-type type)) + (setf (continuation-reoptimize fun-cont) nil))) (values)) -;;; Convert a call to a local function. If the function has already -;;; been LET converted, then throw FUN to LOCAL-CALL-LOSSAGE. This -;;; should only happen when we are converting inline expansions for -;;; local functions during optimization. -(defun ir1-convert-local-combination (start cont form fun) - (if (functional-kind fun) - (throw 'local-call-lossage fun) - (ir1-convert-combination start cont form - (maybe-reanalyze-fun fun)))) +;;; Convert a call to a local function, or if the function has already +;;; been LET converted, then throw FUNCTIONAL to +;;; LOCALL-ALREADY-LET-CONVERTED. The THROW should only happen when we +;;; are converting inline expansions for local functions during +;;; optimization. +(defun ir1-convert-local-combination (start cont form functional) + + ;; The test here is for "when LET converted", as a translation of + ;; the old CMU CL comments into code. Unfortunately, the old CMU CL + ;; comments aren't specific enough to tell whether the correct + ;; translation is FUNCTIONAL-SOMEWHAT-LETLIKE-P or + ;; FUNCTIONAL-LETLIKE-P or what. The old CMU CL code assumed that + ;; any non-null FUNCTIONAL-KIND meant that the function "had been + ;; LET converted", which might even be right, but seems fragile, so + ;; we try to be pickier. + (when (or + ;; looks LET-converted + (functional-somewhat-letlike-p functional) + ;; It's possible for a LET-converted function to end up + ;; deleted later. In that case, for the purposes of this + ;; analysis, it is LET-converted: LET-converted functionals + ;; are too badly trashed to expand them inline, and deleted + ;; LET-converted functionals are even worse. + (eql (functional-kind functional) :deleted)) + (throw 'locall-already-let-converted functional)) + ;; Any other non-NIL KIND value is a case we haven't found a + ;; justification for, and at least some such values (e.g. :EXTERNAL + ;; and :TOPLEVEL) seem obviously wrong. + (aver (null (functional-kind functional))) + + (ir1-convert-combination start + cont + form + (maybe-reanalyze-functional functional))) ;;;; PROCESS-DECLS @@ -865,42 +882,47 @@ (setf found (cdr var))))) found)) -;;; Called by Process-Decls to deal with a variable type declaration. -;;; If a lambda-var being bound, we intersect the type with the vars -;;; type, otherwise we add a type-restriction on the var. If a symbol +;;; Called by PROCESS-DECLS to deal with a variable type declaration. +;;; If a LAMBDA-VAR being bound, we intersect the type with the var's +;;; type, otherwise we add a type restriction on the var. If a symbol ;;; macro, we just wrap a THE around the expansion. (defun process-type-decl (decl res vars) (declare (list decl vars) (type lexenv res)) - (let ((type (specifier-type (first decl)))) + (let ((type (compiler-specifier-type (first decl)))) (collect ((restr nil cons) - (new-vars nil cons)) + (new-vars nil cons)) (dolist (var-name (rest decl)) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var - (lexenv-find var-name variables) - (find-free-variable var-name)))) + (lexenv-find var-name vars) + (find-free-var var-name)))) (etypecase var (leaf - (let* ((old-type (or (lexenv-find var type-restrictions) - (leaf-type var))) - (int (if (or (fun-type-p type) - (fun-type-p old-type)) - type - (type-approx-intersection2 old-type type)))) - (cond ((eq int *empty-type*) - (unless (policy *lexenv* (= inhibit-warnings 3)) - (compiler-warning - "The type declarations ~S and ~S for ~S conflict." - (type-specifier old-type) (type-specifier type) - var-name))) - (bound-var (setf (leaf-type bound-var) int)) - (t - (restr (cons var int)))))) + (flet ((process-var (var bound-var) + (let* ((old-type (or (lexenv-find var type-restrictions) + (leaf-type var))) + (int (if (or (fun-type-p type) + (fun-type-p old-type)) + type + (type-approx-intersection2 old-type type)))) + (cond ((eq int *empty-type*) + (unless (policy *lexenv* (= inhibit-warnings 3)) + (compiler-warn + "The type declarations ~S and ~S for ~S conflict." + (type-specifier old-type) (type-specifier type) + var-name))) + (bound-var (setf (leaf-type bound-var) int)) + (t + (restr (cons var int))))))) + (process-var var bound-var) + (awhen (and (lambda-var-p var) + (lambda-var-specvar var)) + (process-var it nil)))) (cons ;; FIXME: non-ANSI weirdness (aver (eq (car var) 'MACRO)) (new-vars `(,var-name . (MACRO . (the ,(first decl) - ,(cdr var)))))) + ,(cdr var)))))) (heap-alien-info (compiler-error "~S is an alien variable, so its type can't be declared." @@ -909,7 +931,7 @@ (if (or (restr) (new-vars)) (make-lexenv :default res :type-restrictions (restr) - :variables (new-vars)) + :vars (new-vars)) res)))) ;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles @@ -918,8 +940,9 @@ ;;; declarations that constrain the type of lexically apparent ;;; functions. (defun process-ftype-decl (spec res names fvars) - (declare (list spec names fvars) (type lexenv res)) - (let ((type (specifier-type spec))) + (declare (type list names fvars) + (type lexenv res)) + (let ((type (compiler-specifier-type spec))) (collect ((res nil cons)) (dolist (name names) (let ((found (find name fvars @@ -929,10 +952,10 @@ (found (setf (leaf-type found) type) (assert-definition-type found type - :warning-function #'compiler-note + :unwinnage-fun #'compiler-note :where "FTYPE declaration")) (t - (res (cons (find-lexically-apparent-function + (res (cons (find-lexically-apparent-fun name "in a function type declaration") type)))))) (if (res) @@ -957,7 +980,7 @@ (when (lambda-var-ignorep var) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning + (compiler-style-warn "The ignored variable ~S is being declared special." name)) (setf (lambda-var-specvar var) @@ -966,7 +989,7 @@ (unless (assoc name (new-venv) :test #'eq) (new-venv (cons name (specvar-for-binding name)))))))) (if (new-venv) - (make-lexenv :default res :variables (new-venv)) + (make-lexenv :default res :vars (new-venv)) res))) ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP. @@ -996,7 +1019,7 @@ (if fvar (setf (functional-inlinep fvar) sense) (let ((found - (find-lexically-apparent-function + (find-lexically-apparent-fun name "in an inline or notinline declaration"))) (etypecase found (functional @@ -1009,10 +1032,10 @@ new-fenv))))))) (if new-fenv - (make-lexenv :default res :functions new-fenv) + (make-lexenv :default res :funs new-fenv) res))) -;;; Like FIND-IN-BINDINGS, but looks for #'foo in the fvars. +;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS (defun find-in-bindings-or-fbindings (name vars fvars) (declare (list vars fvars)) (if (consp name) @@ -1033,19 +1056,19 @@ ((not var) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning "declaring unknown variable ~S to be ignored" - name)) + (compiler-style-warn "declaring unknown variable ~S to be ignored" + name)) ;; FIXME: This special case looks like non-ANSI weirdness. ((and (consp var) (consp (cdr var)) (eq (cadr var) 'macro)) ;; Just ignore the IGNORE decl. ) ((functional-p var) (setf (leaf-ever-used var) t)) - ((lambda-var-specvar var) + ((and (lambda-var-specvar var) (eq (first spec) 'ignore)) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning "declaring special variable ~S to be ignored" - name)) + (compiler-style-warn "declaring special variable ~S to be ignored" + name)) ((eq (first spec) 'ignorable) (setf (leaf-ever-used var) t)) (t @@ -1070,7 +1093,7 @@ (special (process-special-decl spec res vars)) (ftype (unless (cdr spec) - (compiler-error "No type specified in FTYPE declaration: ~S" spec)) + (compiler-error "no type specified in FTYPE declaration: ~S" spec)) (process-ftype-decl (second spec) res (cddr spec) fvars)) ((inline notinline maybe-inline) (process-inline-decl spec res fvars)) @@ -1083,23 +1106,25 @@ :policy (process-optimize-decl spec (lexenv-policy res)))) (type (process-type-decl (cdr spec) res vars)) - (values - (if *suppress-values-declaration* + (values ;; FIXME -- APD, 2002-01-26 + (if t ; *suppress-values-declaration* res (let ((types (cdr spec))) - (do-the-stuff (if (eql (length types) 1) - (car types) - `(values ,@types)) - cont res 'values)))) + (ir1ize-the-or-values (if (eql (length types) 1) + (car types) + `(values ,@types)) + cont + res + "in VALUES declaration")))) (dynamic-extent (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note - "compiler limitation:~ - ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) + "compiler limitation: ~ + ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) res) (t (unless (info :declaration :recognized (first spec)) - (compiler-warning "unrecognized declaration ~S" raw-spec)) + (compiler-warn "unrecognized declaration ~S" raw-spec)) res)))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR @@ -1116,9 +1141,7 @@ (dolist (decl decls) (dolist (spec (rest decl)) (unless (consp spec) - (compiler-error "malformed declaration specifier ~S in ~S" - spec - decl)) + (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) (setq env (process-1-decl spec env vars fvars cont)))) env) @@ -1128,7 +1151,7 @@ ;;; anonymous GLOBAL-VAR. (defun specvar-for-binding (name) (cond ((not (eq (info :variable :where-from name) :assumed)) - (let ((found (find-free-variable name))) + (let ((found (find-free-var name))) (when (heap-alien-info-p found) (compiler-error "~S is an alien variable and so can't be declared special." @@ -1149,50 +1172,46 @@ ;;;; function representation" before you seriously mess with this ;;;; stuff. -;;; Verify that a thing is a legal name for a variable and return a -;;; Var structure for it, filling in info if it is globally special. -;;; If it is losing, we punt with a Compiler-Error. Names-So-Far is an -;;; alist of names which have previously been bound. If the name is in +;;; Verify that the NAME is a legal name for a variable and return a +;;; VAR structure for it, filling in info if it is globally special. +;;; If it is losing, we punt with a COMPILER-ERROR. NAMES-SO-FAR is a +;;; list of names which have previously been bound. If the NAME is in ;;; this list, then we error out. (declaim (ftype (function (t list) lambda-var) varify-lambda-arg)) (defun varify-lambda-arg (name names-so-far) (declare (inline member)) (unless (symbolp name) - (compiler-error "The lambda-variable ~S is not a symbol." name)) + (compiler-error "The lambda variable ~S is not a symbol." name)) (when (member name names-so-far :test #'eq) - (compiler-error "The variable ~S occurs more than once in the lambda-list." + (compiler-error "The variable ~S occurs more than once in the lambda list." name)) (let ((kind (info :variable :kind name))) (when (or (keywordp name) (eq kind :constant)) - (compiler-error "The name of the lambda-variable ~S is a constant." + (compiler-error "The name of the lambda variable ~S is already in use to name a constant." name)) (cond ((eq kind :special) - (let ((specvar (find-free-variable name))) + (let ((specvar (find-free-var name))) (make-lambda-var :%source-name name :type (leaf-type specvar) :where-from (leaf-where-from specvar) :specvar specvar))) (t - (note-lexical-binding name) (make-lambda-var :%source-name name))))) ;;; Make the default keyword for a &KEY arg, checking that the keyword -;;; isn't already used by one of the VARS. We also check that the -;;; keyword isn't the magical :ALLOW-OTHER-KEYS. +;;; isn't already used by one of the VARS. (declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg)) (defun make-keyword-for-arg (symbol vars keywordify) (let ((key (if (and keywordify (not (keywordp symbol))) (keywordicate symbol) symbol))) - (when (eq key :allow-other-keys) - (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS.")) (dolist (var vars) (let ((info (lambda-var-arg-info var))) (when (and info (eq (arg-info-kind info) :keyword) (eq (arg-info-key info) key)) (compiler-error - "The keyword ~S appears more than once in the lambda-list." + "The keyword ~S appears more than once in the lambda list." key)))) key)) @@ -1211,9 +1230,10 @@ (declaim (ftype (function (list) (values list boolean boolean list list)) make-lambda-vars)) (defun make-lambda-vars (list) - (multiple-value-bind (required optional restp rest keyp keys allowp aux + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) (parse-lambda-list list) + (declare (ignore auxp)) ; since we just iterate over AUX regardless (collect ((vars) (names-so-far) (aux-vars) @@ -1233,16 +1253,17 @@ (compiler-error "The list ~S is too long to be an arg specifier." spec))))))) - + (dolist (name required) (let ((var (varify-lambda-arg name (names-so-far)))) (vars var) (names-so-far name))) - + (dolist (spec optional) (if (atom spec) (let ((var (varify-lambda-arg spec (names-so-far)))) - (setf (lambda-var-arg-info var) (make-arg-info :kind :optional)) + (setf (lambda-var-arg-info var) + (make-arg-info :kind :optional)) (vars var) (names-so-far spec)) (let* ((name (first spec)) @@ -1252,7 +1273,7 @@ (vars var) (names-so-far name) (parse-default spec info)))) - + (when restp (let ((var (varify-lambda-arg rest (names-so-far)))) (setf (lambda-var-arg-info var) (make-arg-info :kind :rest)) @@ -1270,7 +1291,7 @@ (make-arg-info :kind :more-count)) (vars var) (names-so-far more-count))) - + (dolist (spec keys) (cond ((atom spec) @@ -1307,7 +1328,7 @@ (vars var) (names-so-far name) (parse-default spec info)))))) - + (dolist (spec aux) (cond ((atom spec) (let ((var (varify-lambda-arg spec nil))) @@ -1340,12 +1361,12 @@ (ir1-convert-progn-body start cont body) (let ((fun-cont (make-continuation)) (fun (ir1-convert-lambda-body body - (list (first aux-vars)) - :aux-vars (rest aux-vars) - :aux-vals (rest aux-vals) - :debug-name (debug-namify - "&AUX bindings ~S" - aux-vars)))) + (list (first aux-vars)) + :aux-vars (rest aux-vars) + :aux-vals (rest aux-vals) + :debug-name (debug-namify + "&AUX bindings ~S" + aux-vars)))) (reference-leaf start fun-cont fun) (ir1-convert-combination-args fun-cont cont (list (first aux-vals))))) @@ -1385,9 +1406,9 @@ ;;; Create a lambda node out of some code, returning the result. The ;;; bindings are specified by the list of VAR structures VARS. We deal -;;; with adding the names to the LEXENV-VARIABLES for the conversion. -;;; The result is added to the NEW-FUNS in the *CURRENT-COMPONENT* and -;;; linked to the component head and tail. +;;; with adding the names to the LEXENV-VARS for the conversion. The +;;; result is added to the NEW-FUNCTIONALS in the *CURRENT-COMPONENT* +;;; and linked to the component head and tail. ;;; ;;; We detect special bindings here, replacing the original VAR in the ;;; lambda list with a temporary variable. We then pass a list of the @@ -1407,7 +1428,8 @@ aux-vals result (source-name '.anonymous.) - debug-name) + debug-name + (note-lexical-bindings t)) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) @@ -1421,6 +1443,8 @@ :%debug-name debug-name)) (result (or result (make-continuation)))) + (continuation-starts-block result) + ;; just to check: This function should fail internal assertions if ;; we didn't set up a valid debug name above. ;; @@ -1443,22 +1467,23 @@ (svars var) (new-venv (cons (leaf-source-name specvar) specvar))) (t - (note-lexical-binding (leaf-source-name var)) + (when note-lexical-bindings + (note-lexical-binding (leaf-source-name var))) (new-venv (cons (leaf-source-name var) var)))))) - (let ((*lexenv* (make-lexenv :variables (new-venv) + (let ((*lexenv* (make-lexenv :vars (new-venv) :lambda lambda :cleanup nil))) (setf (bind-lambda bind) lambda) (setf (node-lexenv bind) *lexenv*) - + (let ((cont1 (make-continuation)) (cont2 (make-continuation))) (continuation-starts-block cont1) (link-node-to-previous-continuation bind cont1) (use-continuation bind cont2) - (ir1-convert-special-bindings cont2 result body aux-vars aux-vals - (svars))) + (ir1-convert-special-bindings cont2 result body + aux-vars aux-vals (svars))) (let ((block (continuation-block result))) (when block @@ -1468,13 +1493,14 @@ (setf (lambda-tail-set lambda) tail-set) (setf (lambda-return lambda) return) (setf (continuation-dest result) return) + (flush-continuation-externally-checkable-type result) (setf (block-last block) return) (link-node-to-previous-continuation return result) (use-continuation return dummy)) (link-blocks block (component-tail *current-component*)))))) (link-blocks (component-head *current-component*) (node-block bind)) - (push lambda (component-new-funs *current-component*)) + (push lambda (component-new-functionals *current-component*)) lambda)) @@ -1491,19 +1517,27 @@ (declare (type clambda fun) (list vars vals defaults)) (let* ((fvars (reverse vars)) (arg-vars (mapcar (lambda (var) - (unless (lambda-var-specvar var) - (note-lexical-binding (leaf-source-name var))) (make-lambda-var :%source-name (leaf-source-name var) :type (leaf-type var) :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (fun (ir1-convert-lambda-body `((%funcall ,fun - ,@(reverse vals) - ,@defaults)) - arg-vars - :debug-name "&OPTIONAL processor"))) + (fun (collect ((default-bindings) + (default-vals)) + (dolist (default defaults) + (if (constantp default) + (default-vals default) + (let ((var (gensym))) + (default-bindings `(,var ,default)) + (default-vals var)))) + (ir1-convert-lambda-body `((let (,@(default-bindings)) + (%funcall ,fun + ,@(reverse vals) + ,@(default-vals)))) + arg-vars + :debug-name "&OPTIONAL processor" + :note-lexical-bindings nil)))) (mapc (lambda (var arg-var) (when (cdr (leaf-refs arg-var)) (setf (leaf-ever-used var) t))) @@ -1609,7 +1643,8 @@ (n-allowp (gensym "N-ALLOWP-")) (n-losep (gensym "N-LOSEP-")) (allowp (or (optional-dispatch-allowp res) - (policy *lexenv* (zerop safety))))) + (policy *lexenv* (zerop safety)))) + (found-allow-p nil)) (temps `(,n-index (1- ,n-count)) n-key n-value-temp) (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) @@ -1620,30 +1655,37 @@ (default (arg-info-default info)) (keyword (arg-info-key info)) (supplied-p (arg-info-supplied-p info)) - (n-value (gensym "N-VALUE-"))) - (temps `(,n-value ,default)) - (cond (supplied-p - (let ((n-supplied (gensym "N-SUPPLIED-"))) - (temps n-supplied) - (arg-vals n-value n-supplied) - (tests `((eq ,n-key ',keyword) - (setq ,n-supplied t) - (setq ,n-value ,n-value-temp))))) - (t - (arg-vals n-value) - (tests `((eq ,n-key ',keyword) - (setq ,n-value ,n-value-temp))))))) + (n-value (gensym "N-VALUE-")) + (clause (cond (supplied-p + (let ((n-supplied (gensym "N-SUPPLIED-"))) + (temps n-supplied) + (arg-vals n-value n-supplied) + `((eq ,n-key ',keyword) + (setq ,n-supplied t) + (setq ,n-value ,n-value-temp)))) + (t + (arg-vals n-value) + `((eq ,n-key ',keyword) + (setq ,n-value ,n-value-temp)))))) + (when (and (not allowp) (eq keyword :allow-other-keys)) + (setq found-allow-p t) + (setq clause + (append clause `((setq ,n-allowp ,n-value-temp))))) + + (temps `(,n-value ,default)) + (tests clause))) (unless allowp (temps n-allowp n-losep) - (tests `((eq ,n-key :allow-other-keys) - (setq ,n-allowp ,n-value-temp))) + (unless found-allow-p + (tests `((eq ,n-key :allow-other-keys) + (setq ,n-allowp ,n-value-temp)))) (tests `(t (setq ,n-losep ,n-key)))) (body `(when (oddp ,n-count) - (%odd-key-arguments-error))) + (%odd-key-args-error))) (body `(locally @@ -1658,15 +1700,16 @@ (unless allowp (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-key-argument-error ,n-losep))))))) + (%unknown-key-arg-error ,n-losep))))))) (let ((ep (ir1-convert-lambda-body `((let ,(temps) ,@(body) (%funcall ,(optional-dispatch-main-entry res) - . ,(arg-vals)))) ; FIXME: What is the '.'? ,@? + ,@(arg-vals)))) (arg-vars) - :debug-name (debug-namify "~S processing" '&more)))) + :debug-name (debug-namify "~S processing" '&more) + :note-lexical-bindings nil))) (setf (optional-dispatch-more-entry res) ep)))) (values)) @@ -1752,7 +1795,7 @@ :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) :result cont - :debug-name (debug-namify "varargs entry point for ~A" + :debug-name (debug-namify "varargs entry for ~A" (as-debug-name source-name debug-name)))) (last-entry (convert-optional-entry main-entry default-vars @@ -1889,7 +1932,7 @@ :%debug-name debug-name)) (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) (aver-live-component *current-component*) - (push res (component-new-funs *current-component*)) + (push res (component-new-functionals *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals cont source-name debug-name) (setf (optional-dispatch-min-args res) min) @@ -1908,7 +1951,9 @@ res)) ;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf. -(defun ir1-convert-lambda (form &key (source-name '.anonymous.) debug-name) +(defun ir1-convert-lambda (form &key (source-name '.anonymous.) + debug-name + allow-debug-catch-tag) (unless (consp form) (compiler-error "A ~S was found when expecting a lambda expression:~% ~S" @@ -1924,28 +1969,65 @@ "The lambda expression has a missing or non-list lambda list:~% ~S" form)) - (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) - (make-lambda-vars (cadr form)) - (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr form)) - (let* ((result-cont (make-continuation)) - (*lexenv* (process-decls decls - (append aux-vars vars) - nil result-cont)) - (res (if (or (find-if #'lambda-var-arg-info vars) keyp) - (ir1-convert-hairy-lambda forms vars keyp - allow-other-keys - aux-vars aux-vals result-cont - :source-name source-name - :debug-name debug-name) - (ir1-convert-lambda-body forms vars - :aux-vars aux-vars - :aux-vals aux-vals - :result result-cont - :source-name source-name - :debug-name debug-name)))) - (setf (functional-inline-expansion res) form) - (setf (functional-arg-documentation res) (cadr form)) - res)))) + (let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag))) + (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) + (make-lambda-vars (cadr form)) + (multiple-value-bind (forms decls) (parse-body (cddr form)) + (let* ((result-cont (make-continuation)) + (*lexenv* (process-decls decls + (append aux-vars vars) + nil result-cont)) + (forms (if (and *allow-debug-catch-tag* + (policy *lexenv* (> debug (max speed space)))) + `((catch (make-symbol "SB-DEBUG-CATCH-TAG") + ,@forms)) + forms)) + (res (if (or (find-if #'lambda-var-arg-info vars) keyp) + (ir1-convert-hairy-lambda forms vars keyp + allow-other-keys + aux-vars aux-vals result-cont + :source-name source-name + :debug-name debug-name) + (ir1-convert-lambda-body forms vars + :aux-vars aux-vars + :aux-vals aux-vals + :result result-cont + :source-name source-name + :debug-name debug-name)))) + (setf (functional-inline-expansion res) form) + (setf (functional-arg-documentation res) (cadr form)) + res))))) + +;;; helper for LAMBDA-like things, to massage them into a form +;;; suitable for IR1-CONVERT-LAMBDA. +;;; +;;; KLUDGE: We cons up a &REST list here, maybe for no particularly +;;; good reason. It's probably lost in the noise of all the other +;;; consing, but it's still inelegant. And we force our called +;;; functions to do full runtime keyword parsing, ugh. -- CSR, +;;; 2003-01-25 +(defun ir1-convert-lambdalike (thing &rest args + &key (source-name '.anonymous.) + debug-name allow-debug-catch-tag) + (ecase (car thing) + ((lambda) (apply #'ir1-convert-lambda thing args)) + ((instance-lambda) + (let ((res (apply #'ir1-convert-lambda + `(lambda ,@(cdr thing)) args))) + (setf (getf (functional-plist res) :fin-function) t) + res)) + ((named-lambda) + (let ((name (cadr thing))) + (if (legal-fun-name-p name) + (let ((res (apply #'ir1-convert-lambda `(lambda ,@(cddr thing)) + :source-name name + :debug-name nil + args))) + (assert-global-function-definition-type name res) + res) + (apply #'ir1-convert-lambda `(lambda ,@(cddr thing)) + :debug-name name args)))) + ((lambda-with-lexenv) (apply #'ir1-convert-inline-lambda thing args)))) ;;;; defining global functions @@ -1955,7 +2037,8 @@ ;;; reflect the state at the definition site. (defun ir1-convert-inline-lambda (fun &key (source-name '.anonymous.) - debug-name) + debug-name + allow-debug-catch-tag) (destructuring-bind (decls macros symbol-macros &rest body) (if (eq (car fun) 'lambda-with-lexenv) (cdr fun) @@ -1964,23 +2047,23 @@ :default (process-decls decls nil nil (make-continuation) (make-null-lexenv)) - :variables (copy-list symbol-macros) - :functions - (mapcar (lambda (x) - `(,(car x) . - (macro . ,(coerce (cdr x) 'function)))) - macros) + :vars (copy-list symbol-macros) + :funs (mapcar (lambda (x) + `(,(car x) . + (macro . ,(coerce (cdr x) 'function)))) + macros) :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) :source-name source-name - :debug-name debug-name)))) + :debug-name debug-name + :allow-debug-catch-tag nil)))) -;;; 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. +;;; 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-fun (name) (proclaim-as-fun-name name) - (let ((found (find-free-function name "shouldn't happen! (defined-fun)"))) + (let ((found (find-free-fun name "shouldn't happen! (defined-fun)"))) (note-name-defined name :function) (cond ((not (defined-fun-p found)) (aver (not (info :function :inlinep name))) @@ -1991,11 +2074,11 @@ :declared :defined) :type (leaf-type found)))) (substitute-leaf res found) - (setf (gethash name *free-functions*) res))) - ;; If *FREE-FUNCTIONS* has a previously converted definition + (setf (gethash name *free-funs*) res))) + ;; If *FREE-FUNS* has a previously converted definition ;; for this name, then blow it away and try again. ((defined-fun-functional found) - (remhash name *free-functions*) + (remhash name *free-funs*) (get-defined-fun name)) (t found)))) @@ -2018,14 +2101,14 @@ ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't ;; keep track of whether the mismatched data came from the same ;; compilation unit, so we can't do that. -- WHN 2001-02-11 - :error-function #'compiler-style-warning - :warning-function (cond (info #'compiler-style-warning) - (for-real #'compiler-note) - (t nil)) + :lossage-fun #'compiler-style-warn + :unwinnage-fun (cond (info #'compiler-style-warn) + (for-real #'compiler-note) + (t nil)) :really-assert (and for-real (not (and info - (ir1-attributep (function-info-attributes info) + (ir1-attributep (fun-info-attributes info) explicit-check)))) :where (if for-real "previous declaration" @@ -2047,19 +2130,20 @@ (unless (eq (defined-fun-inlinep var) :inline) (setf (defined-fun-inline-expansion var) nil)) (let* ((name (leaf-source-name var)) - (fun (funcall converter lambda :source-name name)) - (function-info (info :function :info name))) + (fun (funcall converter lambda + :source-name name)) + (fun-info (info :function :info name))) (setf (functional-inlinep fun) (defined-fun-inlinep var)) (assert-new-definition var fun) (setf (defined-fun-inline-expansion var) var-expansion) - ;; If definitely not an interpreter stub, then substitute for any - ;; old references. + ;; If definitely not an interpreter stub, then substitute for + ;; any old references. (unless (or (eq (defined-fun-inlinep var) :notinline) (not *block-compile*) - (and function-info - (or (function-info-transforms function-info) - (function-info-templates function-info) - (function-info-ir2-convert function-info)))) + (and fun-info + (or (fun-info-transforms fun-info) + (fun-info-templates fun-info) + (fun-info-ir2-convert fun-info)))) (substitute-leaf fun var) ;; If in a simple environment, then we can allow backward ;; references to this function from following top level forms. @@ -2073,11 +2157,11 @@ (defun %compiler-defun (name lambda-with-lexenv) (let ((defined-fun nil)) ; will be set below if we're in the compiler - + (when (boundp '*lexenv*) ; when in the compiler (when sb!xc:*compile-print* (compiler-mumble "~&; recognizing DEFUN ~S~%" name)) - (remhash name *free-functions*) + (remhash name *free-funs*) (setf defined-fun (get-defined-fun name))) (become-defined-fun-name name) @@ -2085,7 +2169,7 @@ (cond (lambda-with-lexenv (setf (info :function :inline-expansion-designator name) lambda-with-lexenv) - (when defined-fun + (when defined-fun (setf (defined-fun-inline-expansion defined-fun) lambda-with-lexenv))) (t