X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=ca8904d89a4be647b5090ca13137c168e0e7668a;hb=07ab1e4811ab16f95a9a5e8d767426a0787f22c0;hp=2497c0689e253c720d54ff384136c24715620f1b;hpb=ca094620d68447584326dfaac532e7b2f1014d12;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 2497c06..ca8904d 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -87,6 +87,12 @@
         (eq (defined-fun-inlinep fun) :notinline)
         (eq (info :function :inlinep name) :notinline))))
 
+;; This will get redefined in PCL boot.
+(declaim (notinline update-info-for-gf))
+(defun maybe-update-info-for-gf (name)
+  (declare (ignorable name))
+  (values))
+
 ;;; Return a GLOBAL-VAR structure usable for referencing the global
 ;;; function NAME.
 (defun find-global-fun (name latep)
@@ -110,13 +116,16 @@
     (make-global-var
      :kind :global-function
      :%source-name name
-     :type (if (and (not latep)
-                    (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)
+     :type (if (or (eq where :declared)
+                   (and (not latep)
+                        (or *derive-function-types*
+                            (eq where :defined-method)
+                            (and (not (fun-lexically-notinline-p name))
+                                 (member name *fun-names-in-this-file*
+                                         :test #'equal)))))
+               (progn
+                 (maybe-update-info-for-gf name)
+                 (info :function :type name))
                (specifier-type 'function))
      :defined-type (if (eq where :defined)
                        (info :function :type name)
@@ -1138,7 +1147,9 @@
                                  (type-specifier old-type)
                                  (type-specifier type)
                                  var-name))))
-                            (bound-var (setf (leaf-type bound-var) int))
+                            (bound-var
+                             (setf (leaf-type bound-var) int
+                                   (leaf-where-from bound-var) :declared))
                             (t
                              (restr (cons var int)))))))
                (process-var var bound-var)
@@ -1318,54 +1329,59 @@
         (setf (lambda-var-ignorep var) t)))))
   (values))
 
-(defun process-dx-decl (names vars fvars)
+(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))))
-    (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
-        (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) t)
-                      (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) t)
-                  #!-stack-allocatable-closures
-                  (maybe-notify
-                   "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
+    (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))))
+                   (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)))))
 
 ;;; FIXME: This is non-ANSI, so the default should be T, or it should
 ;;; go away, I think.
@@ -1418,8 +1434,8 @@
                        (car types)
                        `(values ,@types)))))
           res))
-       (dynamic-extent
-        (process-dx-decl (cdr spec) vars fvars)
+       ((dynamic-extent truly-dynamic-extent)
+        (process-dx-decl (cdr spec) vars fvars (first spec))
         res)
        ((disable-package-locks enable-package-locks)
         (make-lexenv