X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=728a23a310c2f013d7c1d65e88bc1c4b0518bdac;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=ca8904d89a4be647b5090ca13137c168e0e7668a;hpb=f3839de6871d7d90bfea2d8f2c5a42d09b49a631;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ca8904d..728a23a 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -132,48 +132,51 @@ *universal-type*) :where-from where))) -;;; Has the *FREE-FUNS* entry FREE-FUN become invalid? +;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid? +;;; Drop 'em. ;;; -;;; 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-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 -;;; component, under further obscure circumstances it could be used by +;;; This was added to fix bug 138 in SBCL. It is 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 component, +;;; under further obscure circumstances it could be used by ;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for -;;; *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-fun-p (free-fun) +;;; *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. +;;; +;;; Note: as of 1.0.24.41 this seems to happen only in XC, and the original +;;; BUGS entry also makes it seem like this might not be an issue at all on +;;; target. +(defun clear-invalid-functionals (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-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))))))) + (when (defined-fun-p free-fun) + (setf (defined-fun-functionals free-fun) + (delete-if (lambda (functional) + (or (eq (functional-kind functional) :deleted) + (when (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. + (not (lambda-bind functional)) + ;; If this IR1 stuff belongs to a dead component, + ;; then we can't reuse it without getting into + ;; bizarre confusion. + (eq (component-info (lambda-component functional)) + :dead))))) + (defined-fun-functionals free-fun))) + nil)) ;;; If NAME already has a valid entry in *FREE-FUNS*, then return ;;; the value. Otherwise, make a new GLOBAL-VAR using information from @@ -184,8 +187,9 @@ (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)) - old-free-fun)) + (when old-free-fun + (clear-invalid-functionals old-free-fun) + old-free-fun)) (ecase (info :function :kind name) ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged. (:macro @@ -224,6 +228,9 @@ (t (find-free-fun name context))))) +(defun maybe-find-free-var (name) + (gethash name *free-vars*)) + ;;; Return the LEAF node for a global variable reference to NAME. If ;;; NAME is already entered in *FREE-VARS*, then we just return the ;;; corresponding value. Otherwise, we make a new leaf using @@ -237,7 +244,7 @@ (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)) + (when (eq kind :unknown) (note-undefined-reference name :variable)) (setf (gethash name *free-vars*) (case kind @@ -453,7 +460,7 @@ (let* ((forms (if for-value `(,form) `(,form nil))) (res (ir1-convert-lambda-body forms () - :debug-name (debug-name 'top-level-form form)))) + :debug-name (debug-name 'top-level-form #+sb-xc-host nil #-sb-xc-host form)))) (setf (functional-entry-fun res) res (functional-arg-documentation res) () (functional-kind res) :toplevel) @@ -635,7 +642,10 @@ ;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE ;; which is not flushable, so that unbound dead variables signal ;; an error (bug 412). - (ir1-convert start next result `(symbol-value ',name)) + (ir1-convert start next result + (if (eq (global-var-kind var) :global) + `(symbol-global-value ',name) + `(symbol-value ',name))) (etypecase var (leaf (when (lambda-var-p var) @@ -702,10 +712,12 @@ ;; suppresses compiler-macros. (not (fun-lexically-notinline-p cmacro-fun-name))) (let ((res (careful-expand-macro cmacro-fun form))) - (if (eq res form) - (ir1-convert-common-functoid start next result form - op) - (ir1-convert start next result res))) + (cond ((eq res form) + (ir1-convert-common-functoid start next result form op)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call cmacro-fun-name (ctran-block start) *current-path*)) + (ir1-convert start next result res)))) (ir1-convert-common-functoid start next result form op))))))) ;;; Handles the "common" cases: any other forms except special forms @@ -1012,14 +1024,16 @@ (defined-fun-inlinep var)))) (if (eq inlinep :notinline) (ir1-convert-combination start next result form var) - (let ((transform (info :function - :source-transform - (leaf-source-name var)))) + (let* ((name (leaf-source-name var)) + (transform (info :function :source-transform name))) (if transform (multiple-value-bind (transformed pass) (funcall transform form) - (if pass - (ir1-convert-maybe-predicate start next result form var) - (ir1-convert start next result transformed))) + (cond (pass + (ir1-convert-maybe-predicate start next result form var)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call name (ctran-block start) *current-path*)) + (ir1-convert start next result transformed)))) (ir1-convert-maybe-predicate start next result form var)))))) ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE @@ -1209,6 +1223,16 @@ (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) + ;; While CLHS seems to allow local SPECIAL declarations for constants, + ;; whatever the semantics are supposed to be is not at all clear to me + ;; -- since constants aren't allowed to be bound it should be a no-op as + ;; no-one can observe the difference portably, but specials are allowed + ;; to be bound... yet nowhere does it say that the special declaration + ;; removes the constantness. Call it a spec bug and prohibit it. Same + ;; for GLOBAL variables. + (let ((kind (info :variable :kind name))) + (unless (member kind '(:special :unknown)) + (error "Can't declare ~(~A~) variable locally special: ~S" kind name))) (program-assert-symbol-home-package-unlocked context name "declaring ~A special") (let ((var (find-in-bindings vars name))) @@ -1257,8 +1281,8 @@ (when (defined-fun-p var) (setf (defined-fun-inline-expansion res) (defined-fun-inline-expansion var)) - (setf (defined-fun-functional res) - (defined-fun-functional var))) + (setf (defined-fun-functionals res) + (defined-fun-functionals var))) ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL ;; to the original global-var? res)) @@ -1330,58 +1354,62 @@ (values)) (defun process-dx-decl (names vars fvars kind) - (flet ((maybe-notify (control &rest args) - (when (policy *lexenv* (> speed inhibit-warnings)) - (apply #'compiler-notify control args)))) - (let ((dx (cond ((eq 'truly-dynamic-extent kind) - :truly) - ((and (eq 'dynamic-extent kind) - *stack-allocate-dynamic-extent*) - t)))) - (if dx - (dolist (name names) - (cond - ((symbolp name) - (let* ((bound-var (find-in-bindings vars name)) - (var (or bound-var - (lexenv-find name vars) - (find-free-var name)))) - (etypecase var - (leaf - (if bound-var - (setf (leaf-dynamic-extent var) dx) - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - name))) - (cons - (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) - (heap-alien-info - (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" - name))))) - ((and (consp name) - (eq (car name) 'function) - (null (cddr name)) - (valid-function-name-p (cadr name))) - (let* ((fname (cadr name)) - (bound-fun (find fname fvars - :key #'leaf-source-name - :test #'equal))) - (etypecase bound-fun - (leaf - #!+stack-allocatable-closures - (setf (leaf-dynamic-extent bound-fun) dx) - #!-stack-allocatable-closures - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ - (not supported on this platform)." fname)) - (cons - (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) - (null - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - fname))))) - (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) - (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))) + (let ((dx (cond ((eq 'truly-dynamic-extent kind) + :truly) + ((and (eq 'dynamic-extent kind) + *stack-allocate-dynamic-extent*) + t)))) + (if dx + (dolist (name names) + (cond + ((symbolp name) + (let* ((bound-var (find-in-bindings vars name)) + (var (or bound-var + (lexenv-find name vars) + (maybe-find-free-var name)))) + (etypecase var + (leaf + (if bound-var + (setf (leaf-dynamic-extent var) dx) + (compiler-notify + "Ignoring free DYNAMIC-EXTENT declaration: ~S" name))) + (cons + (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) + (heap-alien-info + (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S" + name)) + (null + (compiler-style-warn + "Unbound variable declared DYNAMIC-EXTENT: ~S" name))))) + ((and (consp name) + (eq (car name) 'function) + (null (cddr name)) + (valid-function-name-p (cadr name))) + (let* ((fname (cadr name)) + (bound-fun (find fname fvars + :key #'leaf-source-name + :test #'equal)) + (fun (or bound-fun (lexenv-find fname funs)))) + (etypecase fun + (leaf + (if bound-fun + #!+stack-allocatable-closures + (setf (leaf-dynamic-extent bound-fun) dx) + #!-stack-allocatable-closures + (compiler-notify + "Ignoring DYNAMIC-EXTENT declaration on function ~S ~ + (not supported on this platform)." fname) + (compiler-notify + "Ignoring free DYNAMIC-EXTENT declaration: ~S" name))) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" name)) + (null + (compiler-style-warn + "Unbound function declared DYNAMIC-EXTENT: ~S" name))))) + (t + (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) + (when (policy *lexenv* (= speed 3)) + (compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names))))) ;;; FIXME: This is non-ANSI, so the default should be T, or it should ;;; go away, I think. @@ -1445,7 +1473,10 @@ (t (unless (info :declaration :recognized (first spec)) (compiler-warn "unrecognized declaration ~S" raw-spec)) - res)) + (let ((fn (info :declaration :handler (first spec)))) + (if fn + (funcall fn res spec vars fvars) + res)))) result-type))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR @@ -1466,14 +1497,20 @@ (*post-binding-variable-lexenv* nil)) (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 lexenv vars fvars binding-form-p context) - (setq lexenv new-env) - (unless (eq new-result-type *wild-type*) - (setq result-type - (values-type-intersection result-type new-result-type)))))) + (progv + ;; Kludge: EVAL calls this function to deal with LOCALLY. + (when (eq context :compile) (list '*current-path*)) + (when (eq context :compile) (list (or (get-source-path spec) + (get-source-path decl) + *current-path*))) + (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 lexenv vars fvars binding-form-p context) + (setq lexenv new-env) + (unless (eq new-result-type *wild-type*) + (setq result-type + (values-type-intersection result-type new-result-type))))))) (values lexenv result-type *post-binding-variable-lexenv*))) (defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun) @@ -1497,7 +1534,7 @@ (check-type ctran symbol) (check-type lvar symbol) (let ((post-binding-lexenv-p (not (null post-binding-lexenv))) - (post-binding-lexenv (or post-binding-lexenv (gensym)))) + (post-binding-lexenv (or post-binding-lexenv (sb!xc:gensym "LEXENV")))) `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar ,post-binding-lexenv-p (lambda (,ctran ,lvar ,post-binding-lexenv)