X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=8f392dcaba47c43ce0cdf573e285e1723bbdd9d5;hb=369029d73f198b59135c6c005b7a70ae5a753650;hp=77c5165128ccab2292e8722e079915daea954c7d;hpb=6e7e59adb6f6c30f84b31695b48cb51e2c519d75;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 77c5165..8f392dc 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -81,7 +81,7 @@ ;;; 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* 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 @@ -96,24 +96,27 @@ ;; (sbcl-0.pre7.118) is this one: (and (defined-fun-p free-fun) (let ((functional (defined-fun-functional free-fun))) - (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)))))) + (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 @@ -121,9 +124,8 @@ ;;; 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 (function (t string) global-var) find-free-fun)) (defun find-free-fun (name context) - (declare (string context)) - (declare (values global-var)) (or (let ((old-free-fun (gethash name *free-funs*))) (and (not (invalid-free-fun-p old-free-fun)) old-free-fun)) @@ -168,8 +170,8 @@ ;;; corresponding value. Otherwise, we make a new leaf using ;;; information from the global environment and enter it in ;;; *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) - (declare (values (or leaf heap-alien-info))) (unless (symbolp name) (compiler-error "Variable name is not a symbol: ~S." name)) (or (gethash name *free-vars*) @@ -182,6 +184,15 @@ (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 @@ -201,7 +212,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) ;; 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)) @@ -417,8 +428,9 @@ 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"))) `(block ,skip @@ -503,26 +515,28 @@ (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 @@ -530,20 +544,23 @@ ;;; 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)) - (setf (leaf-ever-used leaf) t) - (link-node-to-previous-continuation res start) - (use-continuation res cont))) + (with-continuation-type-assertion + (cont (or (lexenv-find leaf type-restrictions) *wild-type*) + "in DECLARE") + (let* ((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)) + (res (make-ref (leaf-type leaf) + leaf))) + (push res (leaf-refs leaf)) + (setf (leaf-ever-used leaf) t) + (link-node-to-previous-continuation res start) + (use-continuation res cont)))) ;;; Convert a reference to a symbolic constant or variable. If the ;;; symbol is entered in the LEXENV-VARS we use that definition, @@ -571,22 +588,31 @@ (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. @@ -805,15 +831,40 @@ (setf (continuation-%type-check 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 @@ -839,9 +890,9 @@ (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)) @@ -1015,7 +1066,7 @@ ) ((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-warn "declaring special variable ~S to be ignored" @@ -1066,7 +1117,7 @@ `(values ,@types)) cont res - 'values)))) + "in VALUES declaration")))) (dynamic-extent (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note @@ -1134,7 +1185,7 @@ (unless (symbolp 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)) @@ -1147,7 +1198,6 @@ :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 @@ -1166,7 +1216,7 @@ (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)) @@ -1185,9 +1235,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) @@ -1361,8 +1412,8 @@ ;;; 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-VARS for the conversion. The -;;; result is added to the NEW-FUNS in the *CURRENT-COMPONENT* and -;;; linked to the component head and tail. +;;; 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 @@ -1432,8 +1483,8 @@ (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 @@ -1449,7 +1500,7 @@ (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)) @@ -1727,7 +1778,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 @@ -1864,7 +1915,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) @@ -1901,7 +1952,7 @@ (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)) + (multiple-value-bind (forms decls) (parse-body (cddr form)) (let* ((result-cont (make-continuation)) (*lexenv* (process-decls decls (append aux-vars vars) @@ -1949,9 +2000,9 @@ :source-name source-name :debug-name debug-name)))) -;;; 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-fun name "shouldn't happen! (defined-fun)"))) @@ -2027,8 +2078,8 @@ (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 fun-info