X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=d09ddcef5aaf04779c5a63d8dd8c31aa85135ef9;hb=0cff6b0b7e6f1d148586f81f620b9c86ed217caa;hp=eddc909d80d8f9c9799c07a566cb71e97b59662f;hpb=5fb561a1daba0b6dbd76f7347d4b0fa4b02494a6;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index eddc909..d09ddce 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)
@@ -112,11 +118,13 @@
      :%source-name name
      :type (if (and (not latep)
                     (or *derive-function-types*
-                        (eq where :declared)
+                        (member where '(:declared :defined-method))
                         (and (member name *fun-names-in-this-file*
                                      :test #'equal)
                              (not (fun-lexically-notinline-p name)))))
-               (info :function :type name)
+               (progn
+                 (maybe-update-info-for-gf name)
+                 (info :function :type name))
                (specifier-type 'function))
      :defined-type (if (eq where :defined)
                        (info :function :type name)
@@ -375,6 +383,17 @@
       (error "~S is already a predecessor of ~S." node-block block))
     (push node-block (block-pred block))))
 
+;;; Insert NEW before OLD in the flow-graph.
+(defun insert-node-before (old new)
+  (let ((prev (node-prev old))
+        (temp (make-ctran)))
+    (ensure-block-start prev)
+    (setf (ctran-next prev) nil)
+    (link-node-to-previous-ctran new prev)
+    (use-ctran new temp)
+    (link-node-to-previous-ctran old temp))
+  (values))
+
 ;;; This function is used to set the ctran for a node, and thus
 ;;; determine what receives the value.
 (defun use-lvar (node lvar)
@@ -1307,54 +1326,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.
@@ -1407,8 +1431,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