X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1tran.lisp;h=71ec219008ad911eda250df5accfb3246b2ad3d5;hb=b7192afcef9bbfd3fe1a4e2bfe3c73f853d164d1;hp=fd63e74b67ac0f2ed894a2459dd87bd56927fa2e;hpb=8731c1a7c1a585d190151fa881050fb5e14c0616;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index fd63e74..71ec219 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -48,9 +48,23 @@ 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-fun (name) @@ -67,13 +81,16 @@ ;; definedness at runtime, which is what matters. #-sb-xc-host (not (fboundp name))) (note-undefined-reference name :function)) - (make-global-var :kind :global-function - :%source-name name - :type (if (or *derive-function-types* - (eq where :declared)) - (info :function :type name) - (specifier-type 'function)) - :where-from where))) + (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? ;;; @@ -124,9 +141,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 (sfunction (t string) global-var) find-free-fun)) (defun find-free-fun (name context) - (declare (string context)) - #+nil (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)) @@ -150,12 +166,14 @@ :inline-expansion expansion :inlinep inlinep :where-from (info :function :where-from name) - :type (info :function :type 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-fun)) +(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 @@ -171,8 +189,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 (sfunction (t) (or leaf cons heap-alien-info)) find-free-var)) (defun find-free-var (name) - #+nil (declare (values (or leaf cons heap-alien-info))) ; see FIXME comment (unless (symbolp name) (compiler-error "Variable name is not a symbol: ~S." name)) (or (gethash name *free-vars*) @@ -211,7 +229,7 @@ ;;; 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 (def!constant list-to-hash-table-threshold 32)) (defun maybe-emit-make-load-forms (constant) @@ -299,10 +317,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)) @@ -330,13 +344,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 @@ -423,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* @@ -452,7 +463,6 @@ ;; 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*) @@ -465,8 +475,10 @@ (t (reference-constant start cont form))) (let ((opname (car form))) - (cond ((symbolp opname) - (let ((lexical-def (lexenv-find opname funs))) + (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 @@ -494,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 @@ -509,7 +522,7 @@ (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))) @@ -530,7 +543,7 @@ (when (typep functional '(or optional-dispatch clambda)) ;; When FUNCTIONAL knows its component - (when (lambda-p functional) + (when (lambda-p functional) (aver (eql (lambda-component functional) *current-component*))) (pushnew functional @@ -544,21 +557,34 @@ ;;; 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)) + (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) - (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-VARS we use that definition, @@ -580,28 +606,38 @@ (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. @@ -646,27 +682,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, @@ -681,9 +702,9 @@ ;; 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 + (compiler-notify "~@<~A~:@_~ ~A~:@_~ ~@<(KLUDGE: That was a non-STYLE WARNING. ~ @@ -698,6 +719,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)))) @@ -707,7 +733,7 @@ ;;; 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) @@ -730,11 +756,11 @@ ;;; 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) +(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 @@ -745,8 +771,6 @@ (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) @@ -773,12 +797,12 @@ (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) + (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