X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=7ee9fed1c4f62cc1c1bb4c18c9f2f7a4186e31da;hb=174feb792c8082846666e1218c58d5b0ab3b85b0;hp=ddca38e14580f03a156c1bc7b57ffe13f5f18668;hpb=16f848f33e91035457132f704448d2d23c34724e;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ddca38e..7ee9fed 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -49,6 +49,8 @@ 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. @@ -56,6 +58,13 @@ ;;;; 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) @@ -72,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? ;;; @@ -129,7 +141,7 @@ ;;; 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)) +(declaim (ftype (sfunction (t string) global-var) find-free-fun)) (defun find-free-fun (name context) (or (let ((old-free-fun (gethash name *free-funs*))) (and (not (invalid-free-fun-p old-free-fun)) @@ -154,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 @@ -175,7 +189,7 @@ ;;; 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)) +(declaim (ftype (sfunction (t) (or leaf cons heap-alien-info)) find-free-var)) (defun find-free-var (name) (unless (symbolp name) (compiler-error "Variable name is not a symbol: ~S." name)) @@ -417,6 +431,8 @@ ;;;; 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 @@ -447,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*) @@ -542,6 +557,8 @@ ;;; functional instead. (defun reference-leaf (start cont leaf) (declare (type continuation start cont) (type leaf 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) @@ -687,7 +704,7 @@ ;; WHN 19990412 #+(and cmu sb-xc-host) (warning (lambda (c) - (compiler-note + (compiler-notify "~@<~A~:@_~ ~A~:@_~ ~@<(KLUDGE: That was a non-STYLE WARNING. ~ @@ -716,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) @@ -739,7 +756,7 @@ ;;; 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))) @@ -780,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
T NIL), ensuring that a @@ -833,30 +850,7 @@ ;;; 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))) - + (assure-functional-live-p functional) (ir1-convert-combination start cont form @@ -868,7 +862,7 @@ ;;; LAMBDA-VAR for that name, or NIL if it isn't found. We return the ;;; *last* variable with that name, since LET* bindings may be ;;; duplicated, and declarations always apply to the last. -(declaim (ftype (function (list symbol) (or lambda-var list)) +(declaim (ftype (sfunction (list symbol) (or lambda-var list)) find-in-bindings)) (defun find-in-bindings (vars name) (let ((found nil)) @@ -956,7 +950,7 @@ (found (setf (leaf-type found) type) (assert-definition-type found type - :unwinnage-fun #'compiler-note + :unwinnage-fun #'compiler-notify :where "FTYPE declaration")) (t (res (cons (find-lexically-apparent-fun @@ -996,13 +990,17 @@ (make-lexenv :default res :vars (new-venv)) res))) -;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP. +;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP +;;; (and TYPE if notinline). (defun make-new-inlinep (var inlinep) (declare (type global-var var) (type inlinep inlinep)) (let ((res (make-defined-fun :%source-name (leaf-source-name var) :where-from (leaf-where-from var) - :type (leaf-type var) + :type (if (and (eq inlinep :notinline) + (not (eq (leaf-where-from var) :declared))) + (specifier-type 'function) + (leaf-type var)) :inlinep inlinep))) (when (defined-fun-p var) (setf (defined-fun-inline-expansion res) @@ -1028,9 +1026,9 @@ (etypecase found (functional (when (policy *lexenv* (>= speed inhibit-warnings)) - (compiler-note "ignoring ~A declaration not at ~ - definition of local function:~% ~S" - sense name))) + (compiler-notify "ignoring ~A declaration not at ~ + definition of local function:~% ~S" + sense name))) (global-var (push (cons name (make-new-inlinep found sense)) new-fenv))))))) @@ -1086,68 +1084,94 @@ "If true, processing of the VALUES declaration is inhibited.") ;;; Process a single declaration spec, augmenting the specified LEXENV -;;; RES and returning it as a result. VARS and FVARS are as described in -;;; PROCESS-DECLS. -(defun process-1-decl (raw-spec res vars fvars cont) +;;; RES. Return RES and result type. VARS and FVARS are as described +;;; in PROCESS-DECLS. +(defun process-1-decl (raw-spec res vars fvars) (declare (type list raw-spec vars fvars)) (declare (type lexenv res)) - (declare (type continuation cont)) - (let ((spec (canonized-decl-spec raw-spec))) - (case (first spec) - (special (process-special-decl spec res vars)) - (ftype - (unless (cdr 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)) - ((ignore ignorable) - (process-ignore-decl spec vars fvars) - res) - (optimize - (make-lexenv - :default res - :policy (process-optimize-decl spec (lexenv-policy res)))) - (type - (process-type-decl (cdr spec) res vars)) - (values ;; FIXME -- APD, 2002-01-26 - (if t ; *suppress-values-declaration* - res - (let ((types (cdr spec))) - (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).")) - res) - (t - (unless (info :declaration :recognized (first spec)) - (compiler-warn "unrecognized declaration ~S" raw-spec)) - res)))) + (let ((spec (canonized-decl-spec raw-spec)) + (result-type *wild-type*)) + (values + (case (first spec) + (special (process-special-decl spec res vars)) + (ftype + (unless (cdr 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)) + ((ignore ignorable) + (process-ignore-decl spec vars fvars) + res) + (optimize + (make-lexenv + :default res + :policy (process-optimize-decl spec (lexenv-policy res)))) + (type + (process-type-decl (cdr spec) res vars)) + (values + (unless *suppress-values-declaration* + (let ((types (cdr spec))) + (setq result-type + (compiler-values-specifier-type + (if (singleton-p types) + (car types) + `(values ,@types))))) + res)) + (dynamic-extent + (when (policy *lexenv* (> speed inhibit-warnings)) + (compiler-notify + "compiler limitation: ~ + ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) + res) + (t + (unless (info :declaration :recognized (first spec)) + (compiler-warn "unrecognized declaration ~S" raw-spec)) + res)) + result-type))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR ;;; and FUNCTIONAL structures which are being bound. In addition to -;;; filling in slots in the leaf structures, we return a new LEXENV +;;; filling in slots in the leaf structures, we return a new LEXENV, ;;; which reflects pervasive special and function type declarations, -;;; (NOT)INLINE declarations and OPTIMIZE declarations. CONT is the -;;; continuation affected by VALUES declarations. +;;; (NOT)INLINE declarations and OPTIMIZE declarations, and type of +;;; VALUES declarations. ;;; ;;; This is also called in main.lisp when PROCESS-FORM handles a use ;;; of LOCALLY. -(defun process-decls (decls vars fvars cont &optional (env *lexenv*)) - (declare (list decls vars fvars) (type continuation cont)) - (dolist (decl decls) - (dolist (spec (rest decl)) - (unless (consp spec) - (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) - (setq env (process-1-decl spec env vars fvars cont)))) - env) +(defun process-decls (decls vars fvars &optional (env *lexenv*)) + (declare (list decls vars fvars)) + (let ((result-type *wild-type*)) + (dolist (decl decls) + (dolist (spec (rest decl)) + (unless (consp spec) + (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) + (multiple-value-bind (new-env new-result-type) + (process-1-decl spec env vars fvars) + (setq env new-env) + (unless (eq new-result-type *wild-type*) + (setq result-type + (values-type-intersection result-type new-result-type)))))) + (values env result-type))) + +(defun %processing-decls (decls vars fvars cont fun) + (multiple-value-bind (*lexenv* result-type) + (process-decls decls vars fvars) + (cond ((eq result-type *wild-type*) + (funcall fun cont)) + (t + (let ((value-cont (make-continuation))) + (multiple-value-prog1 + (funcall fun value-cont) + (let ((cast (make-cast value-cont result-type + (lexenv-policy *lexenv*)))) + (link-node-to-previous-continuation cast value-cont) + (setf (continuation-dest value-cont) cast) + (use-continuation cast cont)))))))) +(defmacro processing-decls ((decls vars fvars cont) &body forms) + (check-type cont symbol) + `(%processing-decls ,decls ,vars ,fvars ,cont + (lambda (,cont) ,@forms))) ;;; Return the SPECVAR for NAME to use when we see a local SPECIAL ;;; declaration. If there is a global variable of that name, then