X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=e6f917fbdc05484e420593ffc3a3232660b0004a;hb=e049902f5e7c30501d2dbb7a41d058a0c717fc1f;hp=520b624db8c283851a60079574dafa4b33240224;hpb=bcbbce86c47a1c530d488c7876a453100fcd933e;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 520b624..e6f917f 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -48,6 +48,11 @@ 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 @@ -124,9 +129,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)) @@ -171,8 +175,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*) @@ -185,6 +189,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 @@ -204,7 +217,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)) @@ -322,11 +335,18 @@ (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) + (let* ((restriction (or (lexenv-find cont type-restrictions) + *wild-type*)) + (wrestriction (or (lexenv-find cont weakend-type-restrictions) + *wild-type*)) + (newatype (values-type-union (continuation-asserted-type cont) + restriction)) + (newctype (values-type-union (continuation-type-to-check cont) + wrestriction))) + (when (or (type/= newatype (continuation-asserted-type cont)) + (type/= newctype (continuation-type-to-check cont))) + (setf (continuation-asserted-type cont) newatype) + (setf (continuation-type-to-check cont) newctype) (reoptimize-continuation cont)))))) ;;;; exported functions @@ -420,8 +440,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 @@ -485,7 +506,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 @@ -535,21 +557,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 ((functional (defined-fun-functional leaf))) - (when (and functional - (not (functional-kind functional))) - (maybe-reanalyze-functional functional)))) - 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, @@ -577,22 +601,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. @@ -637,27 +670,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, @@ -672,7 +690,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~:@_~ @@ -689,6 +707,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,7 +760,9 @@ (let ((node (make-combination fun-cont))) (setf (continuation-dest fun-cont) node) (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) + (specifier-type '(or function symbol)) + (lexenv-policy *lexenv*)) + (setf (continuation-%externally-checkable-type fun-cont) nil) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args) @@ -876,7 +901,7 @@ ;;; 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)) (dolist (var-name (rest decl)) @@ -923,8 +948,10 @@ ;;; 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 type-specifier spec) + (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 @@ -1046,7 +1073,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" @@ -1097,7 +1124,7 @@ `(values ,@types)) cont res - 'values)))) + "in VALUES declaration")))) (dynamic-extent (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note @@ -1178,19 +1205,15 @@ :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 @@ -1216,9 +1239,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) @@ -1459,30 +1483,11 @@ (setf (node-lexenv bind) *lexenv*) (let ((cont1 (make-continuation)) - (cont2 (make-continuation)) - (revised-body (if (policy bind - (or (> safety - (max speed space)) - (= safety 3))) - ;; (Stuffing this in at IR1 level like - ;; this is pretty crude. And it's - ;; particularly inefficient to execute - ;; it on *every* LAMBDA, including - ;; LET-converted LAMBDAs. Improvements - ;; are welcome, but meanwhile, when - ;; SAFETY is high, it's still arguably - ;; an improvement over the old CMU CL - ;; approach of doing nothing (waiting - ;; for evolution to breed careful - ;; users:-). -- WHN) - `((%detect-stack-exhaustion) - ,@body) - body))) + (cont2 (make-continuation))) (continuation-starts-block cont1) (link-node-to-previous-continuation bind cont1) (use-continuation bind cont2) - (ir1-convert-special-bindings cont2 result - revised-body + (ir1-convert-special-bindings cont2 result body aux-vars aux-vals (svars))) (let ((block (continuation-block result))) @@ -1493,6 +1498,7 @@ (setf (lambda-tail-set lambda) tail-set) (setf (lambda-return lambda) return) (setf (continuation-dest result) return) + (setf (continuation-%externally-checkable-type result) nil) (setf (block-last block) return) (link-node-to-previous-continuation return result) (use-continuation return dummy)) @@ -1634,7 +1640,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))) @@ -1645,24 +1652,31 @@ (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)))) @@ -1933,7 +1947,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" @@ -1949,28 +1965,34 @@ "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))))) ;;;; defining global functions @@ -1999,9 +2021,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)"))) @@ -2077,8 +2099,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