1.0.15.9: further ASSOC & MEMBER transform improvements

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index cd08ee2..bd3c298 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -382,6 +382,13 @@
   (awhen (node-lvar node)
     (lvar-dynamic-extent it)))
 
+(defun use-good-for-dx-p (use)
+  (and (combination-p use)
+       (eq (combination-kind use) :known)
+       (awhen (fun-info-stack-allocate-result
+               (combination-fun-info use))
+         (funcall it use))))
+
 (declaim (inline block-to-be-deleted-p))
 (defun block-to-be-deleted-p (block)
   (or (block-delete-p block)
@@ -611,7 +618,10 @@
            (destructuring-bind (name . thing) var
              (declare (ignore name))
              (etypecase thing
-               (leaf nil)
+               ;; The evaluator will mark lexicals with :BOGUS when it
+               ;; translates an interpreter lexenv to a compiler
+               ;; lexenv.
+               ((or leaf #!+sb-eval (member :bogus)) nil)
                (cons (aver (eq (car thing) 'macro))
                      t)
                (heap-alien-info nil)))))
@@ -1015,6 +1025,17 @@
 
   (values))
 
+(defun note-local-functional (fun)
+  (declare (type functional fun))
+  (when (and (leaf-has-source-name-p fun)
+             (eq (leaf-source-name fun) (functional-debug-name fun)))
+    (let ((name (leaf-source-name fun)))
+      (let ((defined-fun (gethash name *free-funs*)))
+        (when (and defined-fun
+                   (defined-fun-p defined-fun)
+                   (eq (defined-fun-functional defined-fun) fun))
+          (remhash name *free-funs*))))))
+
 ;;; Do stuff to delete the semantic attachments of a REF node. When
 ;;; this leaves zero or one reference, we do a type dispatch off of
 ;;; the leaf to determine if a special action is appropriate.
@@ -1411,7 +1432,7 @@
 ;;; of arguments changes, the transform must be prepared to return a
 ;;; lambda with a new lambda-list with the correct number of
 ;;; arguments.
-(defun extract-fun-args (lvar fun num-args)
+(defun splice-fun-args (lvar fun num-args)
   #!+sb-doc
   "If LVAR is a call to FUN with NUM-ARGS args, change those arguments
    to feed directly to the LVAR-DEST of LVAR, which must be a
@@ -1448,6 +1469,22 @@
           (flush-dest lvar)
           (values))))))
 
+(defun extract-fun-args (lvar fun num-args)
+  (declare (type lvar lvar)
+           (type (or symbol list) fun)
+           (type index num-args))
+  (let ((fun (if (listp fun) fun (list fun))))
+    (let ((inside (lvar-uses lvar)))
+      (unless (combination-p inside)
+        (give-up-ir1-transform))
+      (let ((inside-fun (combination-fun inside)))
+        (unless (member (lvar-fun-name inside-fun) fun)
+          (give-up-ir1-transform))
+        (let ((inside-args (combination-args inside)))
+          (unless (= (length inside-args) num-args)
+            (give-up-ir1-transform))
+          (values (lvar-fun-name inside-fun) inside-args))))))
+
 (defun flush-combination (combination)
   (declare (type combination combination))
   (flush-dest (combination-fun combination))
@@ -1599,6 +1636,15 @@
               nil))
         nil)))
 
+(defun lvar-fun-debug-name (lvar)
+  (declare (type lvar lvar))
+  (let ((uses (lvar-uses lvar)))
+    (flet ((name1 (use)
+             (leaf-debug-name (ref-leaf use))))
+      (if (ref-p uses)
+        (name1 uses)
+        (mapcar #'name1 uses)))))
+
 ;;; Return the source name of a combination. (This is an idiom
 ;;; which was used in CMU CL. I gather it always works. -- WHN)
 (defun combination-fun-source-name (combination)
@@ -1813,3 +1859,15 @@
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe)))))))
+
+;;; True if LVAR is for 'NAME, or #'NAME (global, not local)
+(defun lvar-for-named-function (lvar name)
+  (if (constant-lvar-p lvar)
+      (eq name (lvar-value lvar))
+      (let ((use (lvar-uses lvar)))
+        (and (not (listp use))
+             (ref-p use)
+             (let ((leaf (ref-leaf use)))
+               (and (global-var-p leaf)
+                    (eq :global-function (global-var-kind leaf))
+                    (eq name (leaf-source-name leaf))))))))