Fix EQL constraint propagation on constant assigned closure variables

[sbcl.git] / src / compiler / target-disassem.lisp

diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 996bc96..f71c8ca 100644 (file)
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -795,9 +795,7 @@
 
 ;;; Make a disassembler-state object.
 (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*))
-  (let ((sap
-         (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8)))))
-        (alignment *disassem-inst-alignment-bytes*)
+  (let ((alignment *disassem-inst-alignment-bytes*)
         (arg-column
          (+ (or *disassem-opcode-column-width* 0)
             *disassem-location-column-width*
@@ -807,8 +805,7 @@
     (when (> alignment 1)
       (push #'alignment-hook fun-hooks))
 
-    (%make-dstate :segment-sap sap
-                  :fun-hooks fun-hooks
+    (%make-dstate :fun-hooks fun-hooks
                   :argument-column arg-column
                   :alignment alignment
                   :byte-order sb!c:*backend-byte-order*)))
@@ -827,8 +824,8 @@
 \f
 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
 
+;; FIXME: Are the objects we are taking saps for always pinned?
 #!-sb-fluid (declaim (inline sap-maker))
-
 (defun sap-maker (function input offset)
   (declare (optimize (speed 3))
            (type (function (t) sb!sys:system-area-pointer) function)
@@ -946,12 +943,15 @@
   (last-location-retrieved nil :type (or null sb!di:code-location))
   (last-form-retrieved -1 :type fixnum))
 
+;;; OAOO note: this shares a lot of implementation with
+;;; SB-DEBUG::GET-FILE-TOPLEVEL-FORM.  Perhaps these should be merged
+;;; somehow.
 (defun get-toplevel-form (debug-source tlf-index)
-  (let ((name (sb!di:debug-source-name debug-source)))
-    (ecase (sb!di:debug-source-from debug-source)
-      (:file
-       (cond ((not (probe-file name))
-              (warn "The source file ~S no longer seems to exist." name)
+  (cond
+    ((sb!di:debug-source-namestring debug-source)
+     (let ((namestring (sb!di:debug-source-namestring debug-source)))
+       (cond ((not (probe-file namestring))
+              (warn "The source file ~S no longer seems to exist." namestring)
               nil)
              (t
               (let ((start-positions
@@ -966,15 +966,15 @@
                                    debug-source)))
                               (char-offset
                                (aref start-positions local-tlf-index)))
-                         (with-open-file (f name)
+                         (with-open-file (f namestring)
                            (cond ((= (sb!di:debug-source-created debug-source)
-                                     (file-write-date name))
+                                     (file-write-date namestring))
                                   (file-position f char-offset))
                                  (t
                                   (warn "Source file ~S has been modified; ~@
                                          using form offset instead of ~
                                          file index."
-                                        name)
+                                        namestring)
                                   (let ((*read-suppress* t))
                                     (dotimes (i local-tlf-index) (read f)))))
                            (let ((*readtable* (copy-readtable)))
@@ -984,10 +984,11 @@
                                 (declare (ignore rest sub-char))
                                 (let ((token (read stream t nil t)))
                                   (format nil "#.~S" token))))
-                             (read f))
-                           ))))))))
-      (:lisp
-       (aref name tlf-index)))))
+                             (read f)))))))))))
+    ((sb!di:debug-source-form debug-source)
+     (sb!di:debug-source-form debug-source))
+    (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+             a namestring or a form."))))
 
 (defun cache-valid (loc cache)
   (and cache
@@ -1493,12 +1494,16 @@
       (error "can't compile a lexical closure"))
     (compile nil lambda)))
 
-(defun valid-extended-function-designator-for-disassemble-p (thing)
+(defun valid-extended-function-designators-for-disassemble-p (thing)
   (cond ((legal-fun-name-p thing)
-         (compiled-fun-or-lose (fdefinition thing) thing))
+         (compiled-funs-or-lose (fdefinition thing) thing))
         #!+sb-eval
         ((sb!eval:interpreted-function-p thing)
          (compile nil thing))
+        ((typep thing 'sb!pcl::%method-function)
+         ;; in a %METHOD-FUNCTION, the user code is in the fast function, so
+         ;; we to disassemble both.
+         (list thing (sb!pcl::%method-function-fast-function thing)))
         ((functionp thing)
          thing)
         ((and (listp thing)
@@ -1506,13 +1511,13 @@
          (compile nil thing))
         (t nil)))
 
-(defun compiled-fun-or-lose (thing &optional (name thing))
-  (let ((fun (valid-extended-function-designator-for-disassemble-p thing)))
-    (if fun
-        fun
+(defun compiled-funs-or-lose (thing &optional (name thing))
+  (let ((funs (valid-extended-function-designators-for-disassemble-p thing)))
+    (if funs
+        funs
         (error 'simple-type-error
                :datum thing
-               :expected-type '(satisfies valid-extended-function-designator-for-disassemble-p)
+               :expected-type '(satisfies valid-extended-function-designators-for-disassemble-p)
                :format-control "can't make a compiled function from ~S"
                :format-arguments (list name)))))
 
@@ -1527,11 +1532,16 @@
   (declare (type (or function symbol cons) object)
            (type (or (member t) stream) stream)
            (type (member t nil) use-labels))
-  (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
-    (disassemble-fun (compiled-fun-or-lose object)
-                     :stream stream
-                     :use-labels use-labels)
-    nil))
+  (flet ((disassemble1 (fun)
+           (format stream "~&; disassembly for ~S" (sb!kernel:%fun-name fun))
+           (disassemble-fun fun
+                            :stream stream
+                            :use-labels use-labels)))
+    (let ((funs (compiled-funs-or-lose object)))
+      (if (listp funs)
+          (dolist (fun funs) (disassemble1 fun))
+          (disassemble1 funs))))
+  nil)
 
 ;;; Disassembles the given area of memory starting at ADDRESS and
 ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory