0.8.20.1: fun-name fun, debugger debugged

[sbcl.git] / src / compiler / ir1tran.lisp

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 07e2ce2..d7cb33b 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -50,11 +50,6 @@
   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)
 \f
 ;;;; namespace management utilities
 
@@ -244,6 +239,7 @@
               ;; can't contain other objects
               (unless (typep value
                              '(or #-sb-xc-host unboxed-array
+                                  #+sb-xc-host (simple-array (unsigned-byte 8) (*))
                                   symbol
                                   number
                                   character
@@ -390,13 +386,14 @@
   (declare (list path))
   (let* ((*current-path* path)
         (component (make-empty-component))
-        (*current-component* component))
-    (setf (component-name component) "initial component")
+        (*current-component* component)
+         (*allow-instrumenting* t))
+    (setf (component-name component) 'initial-component)
     (setf (component-kind component) :initial)
     (let* ((forms (if for-value `(,form) `(,form nil)))
           (res (ir1-convert-lambda-body
                 forms ()
-                :debug-name (debug-namify "top level form " form))))
+                :debug-name (debug-name 'top-level-form form))))
       (setf (functional-entry-fun res) res
            (functional-arg-documentation res) ()
            (functional-kind res) :toplevel)
@@ -519,12 +516,11 @@
                                                  form
                                                  (ir1-convert-lambda
                                                   opname
-                                                  :debug-name (debug-namify
-                                                               "LAMBDA CAR "
-                                                               opname)
-                                                  :allow-debug-catch-tag t)))))))))
+                                                  :debug-name (debug-name
+                                                               'lambda-car 
+                                                               opname))))))))))
     (values))
-
+  
   ;; Generate a reference to a manifest constant, creating a new leaf
   ;; if necessary. If we are producing a fasl file, make sure that
   ;; MAKE-LOAD-FORM gets used on any parts of the constant that it
@@ -580,7 +576,14 @@
                                  :notinline))
                         (let ((functional (defined-fun-functional leaf)))
                           (when (and functional
-                                     (not (functional-kind functional)))
+                                     (not (functional-kind functional))
+                                     ;; Bug MISC.320: ir1-transform
+                                     ;; can create a reference to a
+                                     ;; inline-expanded function,
+                                     ;; defined in another component.
+                                     (not (and (lambda-p functional)
+                                               (neq (lambda-component functional)
+                                                    *current-component*))))
                             (maybe-reanalyze-functional functional))))
                    (when (and (lambda-p leaf)
                               (memq (functional-kind leaf)
@@ -922,8 +925,8 @@
              (new-vars nil cons))
       (dolist (var-name (rest decl))
        (when (boundp var-name)
-          (compiler-assert-symbol-home-package-unlocked var-name
-                                                        "declaring the type of ~A"))
+          (compiler-assert-symbol-home-package-unlocked
+          var-name "declaring the type of ~A"))
        (let* ((bound-var (find-in-bindings vars var-name))
               (var (or bound-var
                        (lexenv-find var-name vars)
@@ -1072,7 +1075,7 @@
                (functional
                 (when (policy *lexenv* (>= speed inhibit-warnings))
                   (compiler-notify "ignoring ~A declaration not at ~
-                                    definition of local function:~%  ~S"
+                                     definition of local function:~%  ~S"
                                    sense name)))
                (global-var
                 (push (cons name (make-new-inlinep found sense))
@@ -1122,7 +1125,7 @@
        (setf (lambda-var-ignorep var) t)))))
   (values))
 
-(defun process-dx-decl (names vars)
+(defun process-dx-decl (names vars fvars)
   (flet ((maybe-notify (control &rest args)
           (when (policy *lexenv* (> speed inhibit-warnings))
             (apply #'compiler-notify control args))))
@@ -1150,7 +1153,24 @@
                  (eq (car name) 'function)
                  (null (cddr name))
                  (valid-function-name-p (cadr name)))
-            (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" 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 ~
+                    (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))))
 
@@ -1206,12 +1226,12 @@
                        `(values ,@types)))))
           res))
        (dynamic-extent
-       (process-dx-decl (cdr spec) vars)
+       (process-dx-decl (cdr spec) vars fvars)
         res)
        ((disable-package-locks enable-package-locks)
         (make-lexenv
          :default res
-         :disabled-package-locks (process-package-lock-decl 
+         :disabled-package-locks (process-package-lock-decl
                                   spec (lexenv-disabled-package-locks res))))
        (t
         (unless (info :declaration :recognized (first spec))