src/compiler/ir1opt.lisp

   1 ;;;; This file implements the IR1 optimization phase of the compiler.
   2 ;;;; IR1 optimization is a grab-bag of optimizations that don't make
   3 ;;;; major changes to the block-level control flow and don't use flow
   4 ;;;; analysis. These optimizations can mostly be classified as
   5 ;;;; "meta-evaluation", but there is a sizable top-down component as
   6 ;;;; well.
   7
   8 ;;;; This software is part of the SBCL system. See the README file for
   9 ;;;; more information.
  10 ;;;;
  11 ;;;; This software is derived from the CMU CL system, which was
  12 ;;;; written at Carnegie Mellon University and released into the
  13 ;;;; public domain. The software is in the public domain and is
  14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  15 ;;;; files for more information.
  16
  17 (in-package "SB!C")
  18 \f
  19 ;;;; interface for obtaining results of constant folding
  20
  21 ;;; Return true for an LVAR whose sole use is a reference to a
  22 ;;; constant leaf.
  23 (defun constant-lvar-p (thing)
  24   (declare (type (or lvar null) thing))
  25   (and (lvar-p thing)
  26        (let ((use (principal-lvar-use thing)))
  27          (and (ref-p use) (constant-p (ref-leaf use))))))
  28
  29 ;;; Return the constant value for an LVAR whose only use is a constant
  30 ;;; node.
  31 (declaim (ftype (function (lvar) t) lvar-value))
  32 (defun lvar-value (lvar)
  33   (let ((use (principal-lvar-use lvar)))
  34     (constant-value (ref-leaf use))))
  35 \f
  36 ;;;; interface for obtaining results of type inference
  37
  38 ;;; Our best guess for the type of this lvar's value. Note that this
  39 ;;; may be VALUES or FUNCTION type, which cannot be passed as an
  40 ;;; argument to the normal type operations. See LVAR-TYPE.
  41 ;;;
  42 ;;; The result value is cached in the LVAR-%DERIVED-TYPE slot. If the
  43 ;;; slot is true, just return that value, otherwise recompute and
  44 ;;; stash the value there.
  45 #!-sb-fluid (declaim (inline lvar-derived-type))
  46 (defun lvar-derived-type (lvar)
  47   (declare (type lvar lvar))
  48   (or (lvar-%derived-type lvar)
  49       (setf (lvar-%derived-type lvar)
  50             (%lvar-derived-type lvar))))
  51 (defun %lvar-derived-type (lvar)
  52   (declare (type lvar lvar))
  53   (let ((uses (lvar-uses lvar)))
  54     (cond ((null uses) *empty-type*)
  55           ((listp uses)
  56            (do ((res (node-derived-type (first uses))
  57                      (values-type-union (node-derived-type (first current))
  58                                         res))
  59                 (current (rest uses) (rest current)))
  60                ((null current) res)))
  61           (t
  62            (node-derived-type (lvar-uses lvar))))))
  63
  64 ;;; Return the derived type for LVAR's first value. This is guaranteed
  65 ;;; not to be a VALUES or FUNCTION type.
  66 (declaim (ftype (sfunction (lvar) ctype) lvar-type))
  67 (defun lvar-type (lvar)
  68   (single-value-type (lvar-derived-type lvar)))
  69
  70 ;;; If LVAR is an argument of a function, return a type which the
  71 ;;; function checks LVAR for.
  72 #!-sb-fluid (declaim (inline lvar-externally-checkable-type))
  73 (defun lvar-externally-checkable-type (lvar)
  74   (or (lvar-%externally-checkable-type lvar)
  75       (%lvar-%externally-checkable-type lvar)))
  76 (defun %lvar-%externally-checkable-type (lvar)
  77   (declare (type lvar lvar))
  78   (let ((dest (lvar-dest lvar)))
  79     (if (not (and dest (combination-p dest)))
  80         ;; TODO: MV-COMBINATION
  81         (setf (lvar-%externally-checkable-type lvar) *wild-type*)
  82         (let* ((fun (combination-fun dest))
  83                (args (combination-args dest))
  84                (fun-type (lvar-type fun)))
  85           (setf (lvar-%externally-checkable-type fun) *wild-type*)
  86           (if (or (not (call-full-like-p dest))
  87                   (not (fun-type-p fun-type))
  88                   ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
  89                   (fun-type-wild-args fun-type))
  90               (dolist (arg args)
  91                 (when arg
  92                   (setf (lvar-%externally-checkable-type arg)
  93                         *wild-type*)))
  94               (map-combination-args-and-types
  95                (lambda (arg type)
  96                  (setf (lvar-%externally-checkable-type arg)
  97                        (acond ((lvar-%externally-checkable-type arg)
  98                                (values-type-intersection
  99                                 it (coerce-to-values type)))
 100                               (t (coerce-to-values type)))))
 101                dest)))))
 102   (lvar-%externally-checkable-type lvar))
 103 #!-sb-fluid(declaim (inline flush-lvar-externally-checkable-type))
 104 (defun flush-lvar-externally-checkable-type (lvar)
 105   (declare (type lvar lvar))
 106   (setf (lvar-%externally-checkable-type lvar) nil))
 107 \f
 108 ;;;; interface routines used by optimizers
 109
 110 ;;; This function is called by optimizers to indicate that something
 111 ;;; interesting has happened to the value of LVAR. Optimizers must
 112 ;;; make sure that they don't call for reoptimization when nothing has
 113 ;;; happened, since optimization will fail to terminate.
 114 ;;;
 115 ;;; We clear any cached type for the lvar and set the reoptimize flags
 116 ;;; on everything in sight.
 117 (defun reoptimize-lvar (lvar)
 118   (declare (type (or lvar null) lvar))
 119   (when lvar
 120     (setf (lvar-%derived-type lvar) nil)
 121     (let ((dest (lvar-dest lvar)))
 122       (when dest
 123         (setf (lvar-reoptimize lvar) t)
 124         (setf (node-reoptimize dest) t)
 125         (binding* (;; Since this may be called during IR1 conversion,
 126                    ;; PREV may be missing.
 127                    (prev (node-prev dest) :exit-if-null)
 128                    (block (ctran-block prev))
 129                    (component (block-component block)))
 130           (when (typep dest 'cif)
 131             (setf (block-test-modified block) t))
 132           (setf (block-reoptimize block) t)
 133           (setf (component-reoptimize component) t))))
 134     (do-uses (node lvar)
 135       (setf (block-type-check (node-block node)) t)))
 136   (values))
 137
 138 (defun reoptimize-lvar-uses (lvar)
 139   (declare (type lvar lvar))
 140   (do-uses (use lvar)
 141     (setf (node-reoptimize use) t)
 142     (setf (block-reoptimize (node-block use)) t)
 143     (setf (component-reoptimize (node-component use)) t)))
 144
 145 ;;; Annotate NODE to indicate that its result has been proven to be
 146 ;;; TYPEP to RTYPE. After IR1 conversion has happened, this is the
 147 ;;; only correct way to supply information discovered about a node's
 148 ;;; type. If you screw with the NODE-DERIVED-TYPE directly, then
 149 ;;; information may be lost and reoptimization may not happen.
 150 ;;;
 151 ;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the
 152 ;;; intersection is different from the old type, then we do a
 153 ;;; REOPTIMIZE-LVAR on the NODE-LVAR.
 154 (defun derive-node-type (node rtype)
 155   (declare (type valued-node node) (type ctype rtype))
 156   (let ((node-type (node-derived-type node)))
 157     (unless (eq node-type rtype)
 158       (let ((int (values-type-intersection node-type rtype))
 159             (lvar (node-lvar node)))
 160         (when (type/= node-type int)
 161           (when (and *check-consistency*
 162                      (eq int *empty-type*)
 163                      (not (eq rtype *empty-type*)))
 164             (let ((*compiler-error-context* node))
 165               (compiler-warn
 166                "New inferred type ~S conflicts with old type:~
 167                 ~%  ~S~%*** possible internal error? Please report this."
 168                (type-specifier rtype) (type-specifier node-type))))
 169           (setf (node-derived-type node) int)
 170           ;; If the new type consists of only one object, replace the
 171           ;; node with a constant reference.
 172           (when (and (ref-p node)
 173                      (lambda-var-p (ref-leaf node)))
 174             (let ((type (single-value-type int)))
 175               (when (and (member-type-p type)
 176                          (null (rest (member-type-members type))))
 177                 (change-ref-leaf node (find-constant
 178                                        (first (member-type-members type)))))))
 179           (reoptimize-lvar lvar)))))
 180   (values))
 181
 182 ;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
 183 ;;; error for LVAR's value not to be TYPEP to TYPE. We implement it
 184 ;;; splitting off DEST a new CAST node; old LVAR will deliver values
 185 ;;; to CAST. If we improve the assertion, we set TYPE-CHECK and
 186 ;;; TYPE-ASSERTED to guarantee that the new assertion will be checked.
 187 (defun assert-lvar-type (lvar type policy)
 188   (declare (type lvar lvar) (type ctype type))
 189   (unless (values-subtypep (lvar-derived-type lvar) type)
 190     (let* ((dest (lvar-dest lvar))
 191            (ctran (node-prev dest)))
 192       (with-ir1-environment-from-node dest
 193         (let* ((cast (make-cast lvar type policy))
 194                (internal-lvar (make-lvar))
 195                (internal-ctran (make-ctran)))
 196           (setf (ctran-next ctran) cast
 197                 (node-prev cast) ctran)
 198           (use-continuation cast internal-ctran internal-lvar)
 199           (link-node-to-previous-ctran dest internal-ctran)
 200           (substitute-lvar internal-lvar lvar)
 201           (setf (lvar-dest lvar) cast)
 202           (reoptimize-lvar lvar)
 203           (when (return-p dest)
 204             (node-ends-block cast))
 205           (setf (block-attributep (block-flags (node-block cast))
 206                                   type-check type-asserted)
 207                 t))))))
 208
 209 \f
 210 ;;;; IR1-OPTIMIZE
 211
 212 ;;; Do one forward pass over COMPONENT, deleting unreachable blocks
 213 ;;; and doing IR1 optimizations. We can ignore all blocks that don't
 214 ;;; have the REOPTIMIZE flag set. If COMPONENT-REOPTIMIZE is true when
 215 ;;; we are done, then another iteration would be beneficial.
 216 (defun ir1-optimize (component)
 217   (declare (type component component))
 218   (setf (component-reoptimize component) nil)
 219   (do-blocks (block component)
 220     (cond
 221       ;; We delete blocks when there is either no predecessor or the
 222       ;; block is in a lambda that has been deleted. These blocks
 223       ;; would eventually be deleted by DFO recomputation, but doing
 224       ;; it here immediately makes the effect available to IR1
 225       ;; optimization.
 226       ((or (block-delete-p block)
 227            (null (block-pred block)))
 228        (delete-block block))
 229       ((eq (functional-kind (block-home-lambda block)) :deleted)
 230        ;; Preserve the BLOCK-SUCC invariant that almost every block has
 231        ;; one successor (and a block with DELETE-P set is an acceptable
 232        ;; exception).
 233        (mark-for-deletion block)
 234        (delete-block block))
 235       (t
 236        (loop
 237           (let ((succ (block-succ block)))
 238             (unless (singleton-p succ)
 239               (return)))
 240
 241           (let ((last (block-last block)))
 242             (typecase last
 243               (cif
 244                (flush-dest (if-test last))
 245                (when (unlink-node last)
 246                  (return)))
 247               (exit
 248                (when (maybe-delete-exit last)
 249                  (return)))))
 250
 251           (unless (join-successor-if-possible block)
 252             (return)))
 253
 254        (when (and (block-reoptimize block) (block-component block))
 255          (aver (not (block-delete-p block)))
 256          (ir1-optimize-block block))
 257
 258        (cond ((and (block-delete-p block) (block-component block))
 259               (delete-block block))
 260              ((and (block-flush-p block) (block-component block))
 261               (flush-dead-code block))))))
 262
 263   (values))
 264
 265 ;;; Loop over the nodes in BLOCK, acting on (and clearing) REOPTIMIZE
 266 ;;; flags.
 267 ;;;
 268 ;;; Note that although they are cleared here, REOPTIMIZE flags might
 269 ;;; still be set upon return from this function, meaning that further
 270 ;;; optimization is wanted (as a consequence of optimizations we did).
 271 (defun ir1-optimize-block (block)
 272   (declare (type cblock block))
 273   ;; We clear the node and block REOPTIMIZE flags before doing the
 274   ;; optimization, not after. This ensures that the node or block will
 275   ;; be reoptimized if necessary.
 276   (setf (block-reoptimize block) nil)
 277   (do-nodes (node nil block :restart-p t)
 278     (when (node-reoptimize node)
 279       ;; As above, we clear the node REOPTIMIZE flag before optimizing.
 280       (setf (node-reoptimize node) nil)
 281       (typecase node
 282         (ref)
 283         (combination
 284          ;; With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever
 285          ;; the function changes, and call IR1-OPTIMIZE-COMBINATION if
 286          ;; any argument changes.
 287          (ir1-optimize-combination node))
 288         (cif
 289          (ir1-optimize-if node))
 290         (creturn
 291          ;; KLUDGE: We leave the NODE-OPTIMIZE flag set going into
 292          ;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to
 293          ;; clear the flag itself. -- WHN 2002-02-02, quoting original
 294          ;; CMU CL comments
 295          (setf (node-reoptimize node) t)
 296          (ir1-optimize-return node))
 297         (mv-combination
 298          (ir1-optimize-mv-combination node))
 299         (exit
 300          ;; With an EXIT, we derive the node's type from the VALUE's
 301          ;; type.
 302          (let ((value (exit-value node)))
 303            (when value
 304              (derive-node-type node (lvar-derived-type value)))))
 305         (cset
 306          (ir1-optimize-set node))
 307         (cast
 308          (ir1-optimize-cast node)))))
 309
 310   (values))
 311
 312 ;;; Try to join with a successor block. If we succeed, we return true,
 313 ;;; otherwise false.
 314 (defun join-successor-if-possible (block)
 315   (declare (type cblock block))
 316   (let ((next (first (block-succ block))))
 317     (when (block-start next)  ; NEXT is not an END-OF-COMPONENT marker
 318       (cond ( ;; We cannot combine with a successor block if:
 319              (or
 320               ;; The successor has more than one predecessor.
 321               (rest (block-pred next))
 322               ;; The successor is the current block (infinite loop).
 323               (eq next block)
 324               ;; The next block has a different cleanup, and thus
 325               ;; we may want to insert cleanup code between the
 326               ;; two blocks at some point.
 327               (not (eq (block-end-cleanup block)
 328                        (block-start-cleanup next)))
 329               ;; The next block has a different home lambda, and
 330               ;; thus the control transfer is a non-local exit.
 331               (not (eq (block-home-lambda block)
 332                        (block-home-lambda next))))
 333              nil)
 334             (t
 335              (join-blocks block next)
 336              t)))))
 337
 338 ;;; Join together two blocks. The code in BLOCK2 is moved into BLOCK1
 339 ;;; and BLOCK2 is deleted from the DFO. We combine the optimize flags
 340 ;;; for the two blocks so that any indicated optimization gets done.
 341 (defun join-blocks (block1 block2)
 342   (declare (type cblock block1 block2))
 343   (let* ((last1 (block-last block1))
 344          (last2 (block-last block2))
 345          (succ (block-succ block2))
 346          (start2 (block-start block2)))
 347     (do ((ctran start2 (node-next (ctran-next ctran))))
 348         ((not ctran))
 349       (setf (ctran-block ctran) block1))
 350
 351     (unlink-blocks block1 block2)
 352     (dolist (block succ)
 353       (unlink-blocks block2 block)
 354       (link-blocks block1 block))
 355
 356     (setf (ctran-kind start2) :inside-block)
 357     (setf (node-next last1) start2)
 358     (setf (ctran-use start2) last1)
 359     (setf (block-last block1) last2))
 360
 361   (setf (block-flags block1)
 362         (attributes-union (block-flags block1)
 363                           (block-flags block2)
 364                           (block-attributes type-asserted test-modified)))
 365
 366   (let ((next (block-next block2))
 367         (prev (block-prev block2)))
 368     (setf (block-next prev) next)
 369     (setf (block-prev next) prev))
 370
 371   (values))
 372
 373 ;;; Delete any nodes in BLOCK whose value is unused and which have no
 374 ;;; side effects. We can delete sets of lexical variables when the set
 375 ;;; variable has no references.
 376 (defun flush-dead-code (block)
 377   (declare (type cblock block))
 378   (setf (block-flush-p block) nil)
 379   (do-nodes-backwards (node lvar block)
 380     (unless lvar
 381       (typecase node
 382         (ref
 383          (delete-ref node)
 384          (unlink-node node))
 385         (combination
 386          (let ((info (combination-kind node)))
 387            (when (fun-info-p info)
 388              (let ((attr (fun-info-attributes info)))
 389                (when (and (not (ir1-attributep attr call))
 390                           ;; ### For now, don't delete potentially
 391                           ;; flushable calls when they have the CALL
 392                           ;; attribute. Someday we should look at the
 393                           ;; functional args to determine if they have
 394                           ;; any side effects.
 395                           (if (policy node (= safety 3))
 396                               (ir1-attributep attr flushable)
 397                               (ir1-attributep attr unsafely-flushable)))
 398                  (flush-combination node))))))
 399         (mv-combination
 400          (when (eq (basic-combination-kind node) :local)
 401            (let ((fun (combination-lambda node)))
 402              (when (dolist (var (lambda-vars fun) t)
 403                      (when (or (leaf-refs var)
 404                                (lambda-var-sets var))
 405                        (return nil)))
 406                (flush-dest (first (basic-combination-args node)))
 407                (delete-let fun)))))
 408         (exit
 409          (let ((value (exit-value node)))
 410            (when value
 411              (flush-dest value)
 412              (setf (exit-value node) nil))))
 413         (cset
 414          (let ((var (set-var node)))
 415            (when (and (lambda-var-p var)
 416                       (null (leaf-refs var)))
 417              (flush-dest (set-value node))
 418              (setf (basic-var-sets var)
 419                    (delq node (basic-var-sets var)))
 420              (unlink-node node))))
 421         (cast
 422          (unless (cast-type-check node)
 423            (flush-dest (cast-value node))
 424            (unlink-node node))))))
 425
 426   (values))
 427 \f
 428 ;;;; local call return type propagation
 429
 430 ;;; This function is called on RETURN nodes that have their REOPTIMIZE
 431 ;;; flag set. It iterates over the uses of the RESULT, looking for
 432 ;;; interesting stuff to update the TAIL-SET. If a use isn't a local
 433 ;;; call, then we union its type together with the types of other such
 434 ;;; uses. We assign to the RETURN-RESULT-TYPE the intersection of this
 435 ;;; type with the RESULT's asserted type. We can make this
 436 ;;; intersection now (potentially before type checking) because this
 437 ;;; assertion on the result will eventually be checked (if
 438 ;;; appropriate.)
 439 ;;;
 440 ;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV
 441 ;;; combination, which may change the succesor of the call to be the
 442 ;;; called function, and if so, checks if the call can become an
 443 ;;; assignment. If we convert to an assignment, we abort, since the
 444 ;;; RETURN has been deleted.
 445 (defun find-result-type (node)
 446   (declare (type creturn node))
 447   (let ((result (return-result node)))
 448     (collect ((use-union *empty-type* values-type-union))
 449       (do-uses (use result)
 450         (let ((use-home (node-home-lambda use)))
 451           (cond ((or (eq (functional-kind use-home) :deleted)
 452                      (block-delete-p (node-block use))))
 453                 ((and (basic-combination-p use)
 454                       (eq (basic-combination-kind use) :local))
 455                  (aver (eq (lambda-tail-set use-home)
 456                            (lambda-tail-set (combination-lambda use))))
 457                  (when (combination-p use)
 458                    (when (nth-value 1 (maybe-convert-tail-local-call use))
 459                      (return-from find-result-type (values)))))
 460                 (t
 461                  (use-union (node-derived-type use))))))
 462       (let ((int
 463              ;; (values-type-intersection
 464              ;; (continuation-asserted-type result) ; FIXME -- APD, 2002-01-26
 465              (use-union)
 466               ;; )
 467               ))
 468         (setf (return-result-type node) int))))
 469   (values))
 470
 471 ;;; Do stuff to realize that something has changed about the value
 472 ;;; delivered to a return node. Since we consider the return values of
 473 ;;; all functions in the tail set to be equivalent, this amounts to
 474 ;;; bringing the entire tail set up to date. We iterate over the
 475 ;;; returns for all the functions in the tail set, reanalyzing them
 476 ;;; all (not treating NODE specially.)
 477 ;;;
 478 ;;; When we are done, we check whether the new type is different from
 479 ;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize
 480 ;;; all the lvars for references to functions in the tail set. This
 481 ;;; will cause IR1-OPTIMIZE-COMBINATION to derive the new type as the
 482 ;;; results of the calls.
 483 (defun ir1-optimize-return (node)
 484   (declare (type creturn node))
 485   (let* ((tails (lambda-tail-set (return-lambda node)))
 486          (funs (tail-set-funs tails)))
 487     (collect ((res *empty-type* values-type-union))
 488       (dolist (fun funs)
 489         (let ((return (lambda-return fun)))
 490           (when return
 491             (when (node-reoptimize return)
 492               (setf (node-reoptimize return) nil)
 493               (find-result-type return))
 494             (res (return-result-type return)))))
 495
 496       (when (type/= (res) (tail-set-type tails))
 497         (setf (tail-set-type tails) (res))
 498         (dolist (fun (tail-set-funs tails))
 499           (dolist (ref (leaf-refs fun))
 500             (reoptimize-lvar (node-lvar ref)))))))
 501
 502   (values))
 503 \f
 504 ;;;; IF optimization
 505
 506 ;;; If the test has multiple uses, replicate the node when possible.
 507 ;;; Also check whether the predicate is known to be true or false,
 508 ;;; deleting the IF node in favor of the appropriate branch when this
 509 ;;; is the case.
 510 (defun ir1-optimize-if (node)
 511   (declare (type cif node))
 512   (let ((test (if-test node))
 513         (block (node-block node)))
 514
 515     (when (and (eq (block-start-node block) node)
 516                (listp (lvar-uses test)))
 517       (do-uses (use test)
 518         (when (immediately-used-p test use)
 519           (convert-if-if use node)
 520           (when (not (listp (lvar-uses test))) (return)))))
 521
 522     (let* ((type (lvar-type test))
 523            (victim
 524             (cond ((constant-lvar-p test)
 525                    (if (lvar-value test)
 526                        (if-alternative node)
 527                        (if-consequent node)))
 528                   ((not (types-equal-or-intersect type (specifier-type 'null)))
 529                    (if-alternative node))
 530                   ((type= type (specifier-type 'null))
 531                    (if-consequent node)))))
 532       (when victim
 533         (flush-dest test)
 534         (when (rest (block-succ block))
 535           (unlink-blocks block victim))
 536         (setf (component-reanalyze (node-component node)) t)
 537         (unlink-node node))))
 538   (values))
 539
 540 ;;; Create a new copy of an IF node that tests the value of the node
 541 ;;; USE. The test must have >1 use, and must be immediately used by
 542 ;;; USE. NODE must be the only node in its block (implying that
 543 ;;; block-start = if-test).
 544 ;;;
 545 ;;; This optimization has an effect semantically similar to the
 546 ;;; source-to-source transformation:
 547 ;;;    (IF (IF A B C) D E) ==>
 548 ;;;    (IF A (IF B D E) (IF C D E))
 549 ;;;
 550 ;;; We clobber the NODE-SOURCE-PATH of both the original and the new
 551 ;;; node so that dead code deletion notes will definitely not consider
 552 ;;; either node to be part of the original source. One node might
 553 ;;; become unreachable, resulting in a spurious note.
 554 (defun convert-if-if (use node)
 555   (declare (type node use) (type cif node))
 556   (with-ir1-environment-from-node node
 557     (let* ((block (node-block node))
 558            (test (if-test node))
 559            (cblock (if-consequent node))
 560            (ablock (if-alternative node))
 561            (use-block (node-block use))
 562            (new-ctran (make-ctran))
 563            (new-lvar (make-lvar))
 564            (new-node (make-if :test new-lvar
 565                               :consequent cblock
 566                               :alternative ablock))
 567            (new-block (ctran-starts-block new-ctran)))
 568       (link-node-to-previous-ctran new-node new-ctran)
 569       (setf (lvar-dest new-lvar) new-node)
 570       (setf (block-last new-block) new-node)
 571
 572       (unlink-blocks use-block block)
 573       (%delete-lvar-use use)
 574       (add-lvar-use use new-lvar)
 575       (link-blocks use-block new-block)
 576
 577       (link-blocks new-block cblock)
 578       (link-blocks new-block ablock)
 579
 580       (push "<IF Duplication>" (node-source-path node))
 581       (push "<IF Duplication>" (node-source-path new-node))
 582
 583       (reoptimize-lvar test)
 584       (reoptimize-lvar new-lvar)
 585       (setf (component-reanalyze *current-component*) t)))
 586   (values))
 587 \f
 588 ;;;; exit IR1 optimization
 589
 590 ;;; This function attempts to delete an exit node, returning true if
 591 ;;; it deletes the block as a consequence:
 592 ;;; -- If the exit is degenerate (has no ENTRY), then we don't do
 593 ;;;    anything, since there is nothing to be done.
 594 ;;; -- If the exit node and its ENTRY have the same home lambda then
 595 ;;;    we know the exit is local, and can delete the exit. We change
 596 ;;;    uses of the Exit-Value to be uses of the original lvar,
 597 ;;;    then unlink the node. If the exit is to a TR context, then we
 598 ;;;    must do MERGE-TAIL-SETS on any local calls which delivered
 599 ;;;    their value to this exit.
 600 ;;; -- If there is no value (as in a GO), then we skip the value
 601 ;;;    semantics.
 602 ;;;
 603 ;;; This function is also called by environment analysis, since it
 604 ;;; wants all exits to be optimized even if normal optimization was
 605 ;;; omitted.
 606 (defun maybe-delete-exit (node)
 607   (declare (type exit node))
 608   (let ((value (exit-value node))
 609         (entry (exit-entry node)))
 610     (when (and entry
 611                (eq (node-home-lambda node) (node-home-lambda entry)))
 612       (setf (entry-exits entry) (delq node (entry-exits entry)))
 613       (if value
 614           (delete-filter node (node-lvar node) value)
 615           (unlink-node node)))))
 616
 617 \f
 618 ;;;; combination IR1 optimization
 619
 620 ;;; Report as we try each transform?
 621 #!+sb-show
 622 (defvar *show-transforms-p* nil)
 623
 624 ;;; Do IR1 optimizations on a COMBINATION node.
 625 (declaim (ftype (function (combination) (values)) ir1-optimize-combination))
 626 (defun ir1-optimize-combination (node)
 627   (when (lvar-reoptimize (basic-combination-fun node))
 628     (propagate-fun-change node))
 629   (let ((args (basic-combination-args node))
 630         (kind (basic-combination-kind node)))
 631     (case kind
 632       (:local
 633        (let ((fun (combination-lambda node)))
 634          (if (eq (functional-kind fun) :let)
 635              (propagate-let-args node fun)
 636              (propagate-local-call-args node fun))))
 637       ((:full :error)
 638        (dolist (arg args)
 639          (when arg
 640            (setf (lvar-reoptimize arg) nil))))
 641       (t
 642        (dolist (arg args)
 643          (when arg
 644            (setf (lvar-reoptimize arg) nil)))
 645
 646        (let ((attr (fun-info-attributes kind)))
 647          (when (and (ir1-attributep attr foldable)
 648                     ;; KLUDGE: The next test could be made more sensitive,
 649                     ;; only suppressing constant-folding of functions with
 650                     ;; CALL attributes when they're actually passed
 651                     ;; function arguments. -- WHN 19990918
 652                     (not (ir1-attributep attr call))
 653                     (every #'constant-lvar-p args)
 654                     (node-lvar node)
 655                     ;; Even if the function is foldable in principle,
 656                     ;; it might be one of our low-level
 657                     ;; implementation-specific functions. Such
 658                     ;; functions don't necessarily exist at runtime on
 659                     ;; a plain vanilla ANSI Common Lisp
 660                     ;; cross-compilation host, in which case the
 661                     ;; cross-compiler can't fold it because the
 662                     ;; cross-compiler doesn't know how to evaluate it.
 663                     #+sb-xc-host
 664                     (or (fboundp (combination-fun-source-name node))
 665                         (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%"
 666                                        (combination-fun-source-name node)
 667                                        (mapcar #'lvar-value args))
 668                                nil)))
 669            (constant-fold-call node)
 670            (return-from ir1-optimize-combination)))
 671
 672        (let ((fun (fun-info-derive-type kind)))
 673          (when fun
 674            (let ((res (funcall fun node)))
 675              (when res
 676                (derive-node-type node (coerce-to-values res))
 677                (maybe-terminate-block node nil)))))
 678
 679        (let ((fun (fun-info-optimizer kind)))
 680          (unless (and fun (funcall fun node))
 681            (dolist (x (fun-info-transforms kind))
 682              #!+sb-show
 683              (when *show-transforms-p*
 684                (let* ((lvar (basic-combination-fun node))
 685                       (fname (lvar-fun-name lvar t)))
 686                  (/show "trying transform" x (transform-function x) "for" fname)))
 687              (unless (ir1-transform node x)
 688                #!+sb-show
 689                (when *show-transforms-p*
 690                  (/show "quitting because IR1-TRANSFORM result was NIL"))
 691                (return))))))))
 692
 693   (values))
 694
 695 ;;; If NODE doesn't return (i.e. return type is NIL), then terminate
 696 ;;; the block there, and link it to the component tail.
 697 ;;;
 698 ;;; Except when called during IR1 convertion, we delete the
 699 ;;; continuation if it has no other uses. (If it does have other uses,
 700 ;;; we reoptimize.)
 701 ;;;
 702 ;;; Termination on the basis of a continuation type is
 703 ;;; inhibited when:
 704 ;;; -- The continuation is deleted (hence the assertion is spurious), or
 705 ;;; -- We are in IR1 conversion (where THE assertions are subject to
 706 ;;;    weakening.) FIXME: Now THE assertions are not weakened, but new
 707 ;;;    uses can(?) be added later. -- APD, 2003-07-17
 708 ;;;
 709 ;;; Why do we need to consider LVAR type? -- APD, 2003-07-30
 710 (defun maybe-terminate-block (node ir1-converting-not-optimizing-p)
 711   (declare (type (or basic-combination cast) node))
 712   (let* ((block (node-block node))
 713          (lvar (node-lvar node))
 714          (ctran (node-next node))
 715          (tail (component-tail (block-component block)))
 716          (succ (first (block-succ block))))
 717     (unless (or (and (eq node (block-last block)) (eq succ tail))
 718                 (block-delete-p block))
 719       (when (eq (node-derived-type node) *empty-type*)
 720         (cond (ir1-converting-not-optimizing-p
 721                (cond
 722                  ((block-last block)
 723                   (aver (eq (block-last block) node)))
 724                  (t
 725                   (setf (block-last block) node)
 726                   (setf (ctran-use ctran) nil)
 727                   (setf (ctran-kind ctran) :unused)
 728                   (setf (ctran-block ctran) nil)
 729                   (setf (node-next node) nil)
 730                   (link-blocks block (ctran-starts-block ctran)))))
 731               (t
 732                (node-ends-block node)))
 733
 734         (unlink-blocks block (first (block-succ block)))
 735         (setf (component-reanalyze (block-component block)) t)
 736         (aver (not (block-succ block)))
 737         (link-blocks block tail)
 738         (if ir1-converting-not-optimizing-p
 739             (%delete-lvar-use node)
 740             (delete-lvar-use node))
 741         t))))
 742
 743 ;;; This is called both by IR1 conversion and IR1 optimization when
 744 ;;; they have verified the type signature for the call, and are
 745 ;;; wondering if something should be done to special-case the call. If
 746 ;;; CALL is a call to a global function, then see whether it defined
 747 ;;; or known:
 748 ;;; -- If a DEFINED-FUN should be inline expanded, then convert
 749 ;;;    the expansion and change the call to call it. Expansion is
 750 ;;;    enabled if :INLINE or if SPACE=0. If the FUNCTIONAL slot is
 751 ;;;    true, we never expand, since this function has already been
 752 ;;;    converted. Local call analysis will duplicate the definition
 753 ;;;    if necessary. We claim that the parent form is LABELS for
 754 ;;;    context declarations, since we don't want it to be considered
 755 ;;;    a real global function.
 756 ;;; -- If it is a known function, mark it as such by setting the KIND.
 757 ;;;
 758 ;;; We return the leaf referenced (NIL if not a leaf) and the
 759 ;;; FUN-INFO assigned.
 760 (defun recognize-known-call (call ir1-converting-not-optimizing-p)
 761   (declare (type combination call))
 762   (let* ((ref (lvar-uses (basic-combination-fun call)))
 763          (leaf (when (ref-p ref) (ref-leaf ref)))
 764          (inlinep (if (defined-fun-p leaf)
 765                       (defined-fun-inlinep leaf)
 766                       :no-chance)))
 767     (cond
 768      ((eq inlinep :notinline) (values nil nil))
 769      ((not (and (global-var-p leaf)
 770                 (eq (global-var-kind leaf) :global-function)))
 771       (values leaf nil))
 772      ((and (ecase inlinep
 773              (:inline t)
 774              (:no-chance nil)
 775              ((nil :maybe-inline) (policy call (zerop space))))
 776            (defined-fun-p leaf)
 777            (defined-fun-inline-expansion leaf)
 778            (let ((fun (defined-fun-functional leaf)))
 779              (or (not fun)
 780                  (and (eq inlinep :inline) (functional-kind fun))))
 781            (inline-expansion-ok call))
 782       (flet (;; FIXME: Is this what the old CMU CL internal documentation
 783              ;; called semi-inlining? A more descriptive name would
 784              ;; be nice. -- WHN 2002-01-07
 785              (frob ()
 786                (let ((res (ir1-convert-lambda-for-defun
 787                            (defined-fun-inline-expansion leaf)
 788                            leaf t
 789                            #'ir1-convert-inline-lambda)))
 790                  (setf (defined-fun-functional leaf) res)
 791                  (change-ref-leaf ref res))))
 792         (if ir1-converting-not-optimizing-p
 793             (frob)
 794             (with-ir1-environment-from-node call
 795               (frob)
 796               (locall-analyze-component *current-component*))))
 797
 798       (values (ref-leaf (lvar-uses (basic-combination-fun call)))
 799               nil))
 800      (t
 801       (let ((info (info :function :info (leaf-source-name leaf))))
 802         (if info
 803             (values leaf (setf (basic-combination-kind call) info))
 804             (values leaf nil)))))))
 805
 806 ;;; Check whether CALL satisfies TYPE. If so, apply the type to the
 807 ;;; call, and do MAYBE-TERMINATE-BLOCK and return the values of
 808 ;;; RECOGNIZE-KNOWN-CALL. If an error, set the combination kind and
 809 ;;; return NIL, NIL. If the type is just FUNCTION, then skip the
 810 ;;; syntax check, arg/result type processing, but still call
 811 ;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
 812 ;;; and that checking is done by local call analysis.
 813 (defun validate-call-type (call type ir1-converting-not-optimizing-p)
 814   (declare (type combination call) (type ctype type))
 815   (cond ((not (fun-type-p type))
 816          (aver (multiple-value-bind (val win)
 817                    (csubtypep type (specifier-type 'function))
 818                  (or val (not win))))
 819          (recognize-known-call call ir1-converting-not-optimizing-p))
 820         ((valid-fun-use call type
 821                         :argument-test #'always-subtypep
 822                         :result-test #'always-subtypep
 823                         ;; KLUDGE: Common Lisp is such a dynamic
 824                         ;; language that all we can do here in
 825                         ;; general is issue a STYLE-WARNING. It
 826                         ;; would be nice to issue a full WARNING
 827                         ;; in the special case of of type
 828                         ;; mismatches within a compilation unit
 829                         ;; (as in section 3.2.2.3 of the spec)
 830                         ;; but at least as of sbcl-0.6.11, we
 831                         ;; don't keep track of whether the
 832                         ;; mismatched data came from the same
 833                         ;; compilation unit, so we can't do that.
 834                         ;; -- WHN 2001-02-11
 835                         ;;
 836                         ;; FIXME: Actually, I think we could
 837                         ;; issue a full WARNING if the call
 838                         ;; violates a DECLAIM FTYPE.
 839                         :lossage-fun #'compiler-style-warn
 840                         :unwinnage-fun #'compiler-notify)
 841          (assert-call-type call type)
 842          (maybe-terminate-block call ir1-converting-not-optimizing-p)
 843          (recognize-known-call call ir1-converting-not-optimizing-p))
 844         (t
 845          (setf (combination-kind call) :error)
 846          (values nil nil))))
 847
 848 ;;; This is called by IR1-OPTIMIZE when the function for a call has
 849 ;;; changed. If the call is local, we try to LET-convert it, and
 850 ;;; derive the result type. If it is a :FULL call, we validate it
 851 ;;; against the type, which recognizes known calls, does inline
 852 ;;; expansion, etc. If a call to a predicate in a non-conditional
 853 ;;; position or to a function with a source transform, then we
 854 ;;; reconvert the form to give IR1 another chance.
 855 (defun propagate-fun-change (call)
 856   (declare (type combination call))
 857   (let ((*compiler-error-context* call)
 858         (fun-lvar (basic-combination-fun call)))
 859     (setf (lvar-reoptimize fun-lvar) nil)
 860     (case (combination-kind call)
 861       (:local
 862        (let ((fun (combination-lambda call)))
 863          (maybe-let-convert fun)
 864          (unless (member (functional-kind fun) '(:let :assignment :deleted))
 865            (derive-node-type call (tail-set-type (lambda-tail-set fun))))))
 866       (:full
 867        (multiple-value-bind (leaf info)
 868            (validate-call-type call (lvar-type fun-lvar) nil)
 869          (cond ((functional-p leaf)
 870                 (convert-call-if-possible
 871                  (lvar-uses (basic-combination-fun call))
 872                  call))
 873                ((not leaf))
 874                ((and (leaf-has-source-name-p leaf)
 875                      (or (info :function :source-transform (leaf-source-name leaf))
 876                          (and info
 877                               (ir1-attributep (fun-info-attributes info)
 878                                               predicate)
 879                               (let ((lvar (node-lvar call)))
 880                                 (and lvar (not (if-p (lvar-dest lvar))))))))
 881                 (let ((name (leaf-source-name leaf))
 882                       (dummies (make-gensym-list
 883                                 (length (combination-args call)))))
 884                   (transform-call call
 885                                   `(lambda ,dummies
 886                                      (,@(if (symbolp name)
 887                                             `(,name)
 888                                             `(funcall #',name))
 889                                         ,@dummies))
 890                                   (leaf-source-name leaf)))))))))
 891   (values))
 892 \f
 893 ;;;; known function optimization
 894
 895 ;;; Add a failed optimization note to FAILED-OPTIMZATIONS for NODE,
 896 ;;; FUN and ARGS. If there is already a note for NODE and TRANSFORM,
 897 ;;; replace it, otherwise add a new one.
 898 (defun record-optimization-failure (node transform args)
 899   (declare (type combination node) (type transform transform)
 900            (type (or fun-type list) args))
 901   (let* ((table (component-failed-optimizations *component-being-compiled*))
 902          (found (assoc transform (gethash node table))))
 903     (if found
 904         (setf (cdr found) args)
 905         (push (cons transform args) (gethash node table))))
 906   (values))
 907
 908 ;;; Attempt to transform NODE using TRANSFORM-FUNCTION, subject to the
 909 ;;; call type constraint TRANSFORM-TYPE. If we are inhibited from
 910 ;;; doing the transform for some reason and FLAME is true, then we
 911 ;;; make a note of the message in FAILED-OPTIMIZATIONS for IR1
 912 ;;; finalize to pick up. We return true if the transform failed, and
 913 ;;; thus further transformation should be attempted. We return false
 914 ;;; if either the transform succeeded or was aborted.
 915 (defun ir1-transform (node transform)
 916   (declare (type combination node) (type transform transform))
 917   (let* ((type (transform-type transform))
 918          (fun (transform-function transform))
 919          (constrained (fun-type-p type))
 920          (table (component-failed-optimizations *component-being-compiled*))
 921          (flame (if (transform-important transform)
 922                     (policy node (>= speed inhibit-warnings))
 923                     (policy node (> speed inhibit-warnings))))
 924          (*compiler-error-context* node))
 925     (cond ((or (not constrained)
 926                (valid-fun-use node type))
 927            (multiple-value-bind (severity args)
 928                (catch 'give-up-ir1-transform
 929                  (transform-call node
 930                                  (funcall fun node)
 931                                  (combination-fun-source-name node))
 932                  (values :none nil))
 933              (ecase severity
 934                (:none
 935                 (remhash node table)
 936                 nil)
 937                (:aborted
 938                 (setf (combination-kind node) :error)
 939                 (when args
 940                   (apply #'compiler-warn args))
 941                 (remhash node table)
 942                 nil)
 943                (:failure
 944                 (if args
 945                     (when flame
 946                       (record-optimization-failure node transform args))
 947                     (setf (gethash node table)
 948                           (remove transform (gethash node table) :key #'car)))
 949                 t)
 950                (:delayed
 951                  (remhash node table)
 952                  nil))))
 953           ((and flame
 954                 (valid-fun-use node
 955                                type
 956                                :argument-test #'types-equal-or-intersect
 957                                :result-test #'values-types-equal-or-intersect))
 958            (record-optimization-failure node transform type)
 959            t)
 960           (t
 961            t))))
 962
 963 ;;; When we don't like an IR1 transform, we throw the severity/reason
 964 ;;; and args.
 965 ;;;
 966 ;;; GIVE-UP-IR1-TRANSFORM is used to throw out of an IR1 transform,
 967 ;;; aborting this attempt to transform the call, but admitting the
 968 ;;; possibility that this or some other transform will later succeed.
 969 ;;; If arguments are supplied, they are format arguments for an
 970 ;;; efficiency note.
 971 ;;;
 972 ;;; ABORT-IR1-TRANSFORM is used to throw out of an IR1 transform and
 973 ;;; force a normal call to the function at run time. No further
 974 ;;; optimizations will be attempted.
 975 ;;;
 976 ;;; DELAY-IR1-TRANSFORM is used to throw out of an IR1 transform, and
 977 ;;; delay the transform on the node until later. REASONS specifies
 978 ;;; when the transform will be later retried. The :OPTIMIZE reason
 979 ;;; causes the transform to be delayed until after the current IR1
 980 ;;; optimization pass. The :CONSTRAINT reason causes the transform to
 981 ;;; be delayed until after constraint propagation.
 982 ;;;
 983 ;;; FIXME: Now (0.6.11.44) that there are 4 variants of this (GIVE-UP,
 984 ;;; ABORT, DELAY/:OPTIMIZE, DELAY/:CONSTRAINT) and we're starting to
 985 ;;; do CASE operations on the various REASON values, it might be a
 986 ;;; good idea to go OO, representing the reasons by objects, using
 987 ;;; CLOS methods on the objects instead of CASE, and (possibly) using
 988 ;;; SIGNAL instead of THROW.
 989 (declaim (ftype (function (&rest t) nil) give-up-ir1-transform))
 990 (defun give-up-ir1-transform (&rest args)
 991   (throw 'give-up-ir1-transform (values :failure args)))
 992 (defun abort-ir1-transform (&rest args)
 993   (throw 'give-up-ir1-transform (values :aborted args)))
 994 (defun delay-ir1-transform (node &rest reasons)
 995   (let ((assoc (assoc node *delayed-ir1-transforms*)))
 996     (cond ((not assoc)
 997             (setf *delayed-ir1-transforms*
 998                     (acons node reasons *delayed-ir1-transforms*))
 999             (throw 'give-up-ir1-transform :delayed))
1000           ((cdr assoc)
1001             (dolist (reason reasons)
1002               (pushnew reason (cdr assoc)))
1003             (throw 'give-up-ir1-transform :delayed)))))
1004
1005 ;;; Clear any delayed transform with no reasons - these should have
1006 ;;; been tried in the last pass. Then remove the reason from the
1007 ;;; delayed transform reasons, and if any become empty then set
1008 ;;; reoptimize flags for the node. Return true if any transforms are
1009 ;;; to be retried.
1010 (defun retry-delayed-ir1-transforms (reason)
1011   (setf *delayed-ir1-transforms*
1012         (remove-if-not #'cdr *delayed-ir1-transforms*))
1013   (let ((reoptimize nil))
1014     (dolist (assoc *delayed-ir1-transforms*)
1015       (let ((reasons (remove reason (cdr assoc))))
1016         (setf (cdr assoc) reasons)
1017         (unless reasons
1018           (let ((node (car assoc)))
1019             (unless (node-deleted node)
1020               (setf reoptimize t)
1021               (setf (node-reoptimize node) t)
1022               (let ((block (node-block node)))
1023                 (setf (block-reoptimize block) t)
1024                 (setf (component-reoptimize (block-component block)) t)))))))
1025     reoptimize))
1026
1027 ;;; Take the lambda-expression RES, IR1 convert it in the proper
1028 ;;; environment, and then install it as the function for the call
1029 ;;; NODE. We do local call analysis so that the new function is
1030 ;;; integrated into the control flow.
1031 ;;;
1032 ;;; We require the original function source name in order to generate
1033 ;;; a meaningful debug name for the lambda we set up. (It'd be
1034 ;;; possible to do this starting from debug names as well as source
1035 ;;; names, but as of sbcl-0.7.1.5, there was no need for this
1036 ;;; generality, since source names are always known to our callers.)
1037 (defun transform-call (call res source-name)
1038   (declare (type combination call) (list res))
1039   (aver (and (legal-fun-name-p source-name)
1040              (not (eql source-name '.anonymous.))))
1041   (node-ends-block call)
1042   (with-ir1-environment-from-node call
1043     (with-component-last-block (*current-component*
1044                                 (block-next (node-block call)))
1045       (let ((new-fun (ir1-convert-inline-lambda
1046                       res
1047                       :debug-name (debug-namify "LAMBDA-inlined ~A"
1048                                                 (as-debug-name
1049                                                  source-name
1050                                                  "<unknown function>"))))
1051             (ref (lvar-use (combination-fun call))))
1052         (change-ref-leaf ref new-fun)
1053         (setf (combination-kind call) :full)
1054         (locall-analyze-component *current-component*))))
1055   (values))
1056
1057 ;;; Replace a call to a foldable function of constant arguments with
1058 ;;; the result of evaluating the form. If there is an error during the
1059 ;;; evaluation, we give a warning and leave the call alone, making the
1060 ;;; call a :ERROR call.
1061 ;;;
1062 ;;; If there is more than one value, then we transform the call into a
1063 ;;; VALUES form.
1064 (defun constant-fold-call (call)
1065   (let ((args (mapcar #'lvar-value (combination-args call)))
1066         (fun-name (combination-fun-source-name call)))
1067     (multiple-value-bind (values win)
1068         (careful-call fun-name
1069                       args
1070                       call
1071                       ;; Note: CMU CL had COMPILER-WARN here, and that
1072                       ;; seems more natural, but it's probably not.
1073                       ;;
1074                       ;; It's especially not while bug 173 exists:
1075                       ;; Expressions like
1076                       ;;   (COND (END
1077                       ;;          (UNLESS (OR UNSAFE? (<= END SIZE)))
1078                       ;;            ...))
1079                       ;; can cause constant-folding TYPE-ERRORs (in
1080                       ;; #'<=) when END can be proved to be NIL, even
1081                       ;; though the code is perfectly legal and safe
1082                       ;; because a NIL value of END means that the
1083                       ;; #'<= will never be executed.
1084                       ;;
1085                       ;; Moreover, even without bug 173,
1086                       ;; quite-possibly-valid code like
1087                       ;;   (COND ((NONINLINED-PREDICATE END)
1088                       ;;          (UNLESS (<= END SIZE))
1089                       ;;            ...))
1090                       ;; (where NONINLINED-PREDICATE is something the
1091                       ;; compiler can't do at compile time, but which
1092                       ;; turns out to make the #'<= expression
1093                       ;; unreachable when END=NIL) could cause errors
1094                       ;; when the compiler tries to constant-fold (<=
1095                       ;; END SIZE).
1096                       ;;
1097                       ;; So, with or without bug 173, it'd be
1098                       ;; unnecessarily evil to do a full
1099                       ;; COMPILER-WARNING (and thus return FAILURE-P=T
1100                       ;; from COMPILE-FILE) for legal code, so we we
1101                       ;; use a wimpier COMPILE-STYLE-WARNING instead.
1102                       #'compiler-style-warn
1103                       "constant folding")
1104       (cond ((not win)
1105              (setf (combination-kind call) :error))
1106             ((and (proper-list-of-length-p values 1))
1107              (with-ir1-environment-from-node call
1108                (let* ((lvar (node-lvar call))
1109                       (prev (node-prev call))
1110                       (intermediate-ctran (make-ctran)))
1111                  (%delete-lvar-use call)
1112                  (setf (ctran-next prev) nil)
1113                  (setf (node-prev call) nil)
1114                  (reference-constant prev intermediate-ctran lvar
1115                                      (first values))
1116                  (link-node-to-previous-ctran call intermediate-ctran)
1117                  (reoptimize-lvar lvar)
1118                  (flush-combination call))))
1119             (t (let ((dummies (make-gensym-list (length args))))
1120                  (transform-call
1121                   call
1122                   `(lambda ,dummies
1123                      (declare (ignore ,@dummies))
1124                      (values ,@(mapcar (lambda (x) `',x) values)))
1125                   fun-name))))))
1126   (values))
1127 \f
1128 ;;;; local call optimization
1129
1130 ;;; Propagate TYPE to LEAF and its REFS, marking things changed. If
1131 ;;; the leaf type is a function type, then just leave it alone, since
1132 ;;; TYPE is never going to be more specific than that (and
1133 ;;; TYPE-INTERSECTION would choke.)
1134 (defun propagate-to-refs (leaf type)
1135   (declare (type leaf leaf) (type ctype type))
1136   (let ((var-type (leaf-type leaf)))
1137     (unless (fun-type-p var-type)
1138       (let ((int (type-approx-intersection2 var-type type)))
1139         (when (type/= int var-type)
1140           (setf (leaf-type leaf) int)
1141           (dolist (ref (leaf-refs leaf))
1142             (derive-node-type ref (make-single-value-type int))
1143             ;; KLUDGE: LET var substitution
1144             (let* ((lvar (node-lvar ref)))
1145               (when (and lvar (combination-p (lvar-dest lvar)))
1146                 (reoptimize-lvar lvar))))))
1147       (values))))
1148
1149 ;;; Iteration variable: exactly one SETQ of the form:
1150 ;;;
1151 ;;; (let ((var initial))
1152 ;;;   ...
1153 ;;;   (setq var (+ var step))
1154 ;;;   ...)
1155 (defun maybe-infer-iteration-var-type (var initial-type)
1156   (binding* ((sets (lambda-var-sets var) :exit-if-null)
1157              (set (first sets))
1158              (() (null (rest sets)) :exit-if-null)
1159              (set-use (principal-lvar-use (set-value set)))
1160              (() (and (combination-p set-use)
1161                       (fun-info-p (combination-kind set-use))
1162                       (eq (combination-fun-source-name set-use) '+))
1163                :exit-if-null)
1164              (+-args (basic-combination-args set-use))
1165              (() (and (proper-list-of-length-p +-args 2 2)
1166                       (let ((first (principal-lvar-use
1167                                     (first +-args))))
1168                         (and (ref-p first)
1169                              (eq (ref-leaf first) var))))
1170                :exit-if-null)
1171              (step-type (lvar-type (second +-args)))
1172              (set-type (lvar-type (set-value set))))
1173     (when (and (numeric-type-p initial-type)
1174                (numeric-type-p step-type)
1175                (numeric-type-equal initial-type step-type))
1176       (multiple-value-bind (low high)
1177           (cond ((csubtypep step-type (specifier-type '(real 0 *)))
1178                  (values (numeric-type-low initial-type)
1179                          (when (and (numeric-type-p set-type)
1180                                     (numeric-type-equal set-type initial-type))
1181                            (numeric-type-high set-type))))
1182                 ((csubtypep step-type (specifier-type '(real * 0)))
1183                  (values (when (and (numeric-type-p set-type)
1184                                     (numeric-type-equal set-type initial-type))
1185                            (numeric-type-low set-type))
1186                          (numeric-type-high initial-type)))
1187                 (t
1188                  (values nil nil)))
1189         (modified-numeric-type initial-type
1190                                :low low
1191                                :high high
1192                                :enumerable nil)))))
1193 (deftransform + ((x y) * * :result result)
1194   "check for iteration variable reoptimization"
1195   (let ((dest (principal-lvar-end result))
1196         (use (principal-lvar-use x)))
1197     (when (and (ref-p use)
1198                (set-p dest)
1199                (eq (ref-leaf use)
1200                    (set-var dest)))
1201       (reoptimize-lvar (set-value dest))))
1202   (give-up-ir1-transform))
1203
1204 ;;; Figure out the type of a LET variable that has sets. We compute
1205 ;;; the union of the INITIAL-TYPE and the types of all the set
1206 ;;; values and to a PROPAGATE-TO-REFS with this type.
1207 (defun propagate-from-sets (var initial-type)
1208   (collect ((res initial-type type-union))
1209     (dolist (set (basic-var-sets var))
1210       (let ((type (lvar-type (set-value set))))
1211         (res type)
1212         (when (node-reoptimize set)
1213           (derive-node-type set (make-single-value-type type))
1214           (setf (node-reoptimize set) nil))))
1215     (let ((res (res)))
1216       (awhen (maybe-infer-iteration-var-type var initial-type)
1217         (setq res it))
1218       (propagate-to-refs var res)))
1219   (values))
1220
1221 ;;; If a LET variable, find the initial value's type and do
1222 ;;; PROPAGATE-FROM-SETS. We also derive the VALUE's type as the node's
1223 ;;; type.
1224 (defun ir1-optimize-set (node)
1225   (declare (type cset node))
1226   (let ((var (set-var node)))
1227     (when (and (lambda-var-p var) (leaf-refs var))
1228       (let ((home (lambda-var-home var)))
1229         (when (eq (functional-kind home) :let)
1230           (let* ((initial-value (let-var-initial-value var))
1231                  (initial-type (lvar-type initial-value)))
1232             (setf (lvar-reoptimize initial-value) nil)
1233             (propagate-from-sets var initial-type))))))
1234
1235   (derive-node-type node (make-single-value-type
1236                           (lvar-type (set-value node))))
1237   (values))
1238
1239 ;;; Return true if the value of REF will always be the same (and is
1240 ;;; thus legal to substitute.)
1241 (defun constant-reference-p (ref)
1242   (declare (type ref ref))
1243   (let ((leaf (ref-leaf ref)))
1244     (typecase leaf
1245       ((or constant functional) t)
1246       (lambda-var
1247        (null (lambda-var-sets leaf)))
1248       (defined-fun
1249        (not (eq (defined-fun-inlinep leaf) :notinline)))
1250       (global-var
1251        (case (global-var-kind leaf)
1252          (:global-function
1253           (let ((name (leaf-source-name leaf)))
1254             (or #-sb-xc-host
1255                 (eq (symbol-package (fun-name-block-name name))
1256                     *cl-package*)
1257                 (info :function :info name)))))))))
1258
1259 ;;; If we have a non-set LET var with a single use, then (if possible)
1260 ;;; replace the variable reference's LVAR with the arg lvar.
1261 ;;;
1262 ;;; We change the REF to be a reference to NIL with unused value, and
1263 ;;; let it be flushed as dead code. A side effect of this substitution
1264 ;;; is to delete the variable.
1265 (defun substitute-single-use-lvar (arg var)
1266   (declare (type lvar arg) (type lambda-var var))
1267   (binding* ((ref (first (leaf-refs var)))
1268              (lvar (node-lvar ref) :exit-if-null)
1269              (dest (lvar-dest lvar)))
1270     (when (and
1271            ;; Think about (LET ((A ...)) (IF ... A ...)): two
1272            ;; LVAR-USEs should not be met on one path.
1273            (eq (lvar-uses lvar) ref)
1274            (typecase dest
1275              ;; we should not change lifetime of unknown values lvars
1276              (cast
1277               (and (type-single-value-p (lvar-derived-type arg))
1278                    (multiple-value-bind (pdest pprev)
1279                        (principal-lvar-end lvar)
1280                      (declare (ignore pdest))
1281                      (lvar-single-value-p pprev))))
1282              (mv-combination
1283               (or (eq (basic-combination-fun dest) lvar)
1284                   (and (eq (basic-combination-kind dest) :local)
1285                        (type-single-value-p (lvar-derived-type arg)))))
1286              ((or creturn exit)
1287               ;; While CRETURN and EXIT nodes may be known-values,
1288               ;; they have their own complications, such as
1289               ;; substitution into CRETURN may create new tail calls.
1290               nil)
1291              (t
1292               (aver (lvar-single-value-p lvar))
1293               t))
1294            (eq (node-home-lambda ref)
1295                (lambda-home (lambda-var-home var))))
1296       (setf (node-derived-type ref) *wild-type*)
1297       (substitute-lvar-uses lvar arg)
1298       (delete-lvar-use ref)
1299       (change-ref-leaf ref (find-constant nil))
1300       (delete-ref ref)
1301       (unlink-node ref)
1302       (reoptimize-lvar lvar)
1303       t)))
1304
1305 ;;; Delete a LET, removing the call and bind nodes, and warning about
1306 ;;; any unreferenced variables. Note that FLUSH-DEAD-CODE will come
1307 ;;; along right away and delete the REF and then the lambda, since we
1308 ;;; flush the FUN lvar.
1309 (defun delete-let (clambda)
1310   (declare (type clambda clambda))
1311   (aver (functional-letlike-p clambda))
1312   (note-unreferenced-vars clambda)
1313   (let ((call (let-combination clambda)))
1314     (flush-dest (basic-combination-fun call))
1315     (unlink-node call)
1316     (unlink-node (lambda-bind clambda))
1317     (setf (lambda-bind clambda) nil))
1318   (values))
1319
1320 ;;; This function is called when one of the arguments to a LET
1321 ;;; changes. We look at each changed argument. If the corresponding
1322 ;;; variable is set, then we call PROPAGATE-FROM-SETS. Otherwise, we
1323 ;;; consider substituting for the variable, and also propagate
1324 ;;; derived-type information for the arg to all the VAR's refs.
1325 ;;;
1326 ;;; Substitution is inhibited when the arg leaf's derived type isn't a
1327 ;;; subtype of the argument's leaf type. This prevents type checking
1328 ;;; from being defeated, and also ensures that the best representation
1329 ;;; for the variable can be used.
1330 ;;;
1331 ;;; Substitution of individual references is inhibited if the
1332 ;;; reference is in a different component from the home. This can only
1333 ;;; happen with closures over top level lambda vars. In such cases,
1334 ;;; the references may have already been compiled, and thus can't be
1335 ;;; retroactively modified.
1336 ;;;
1337 ;;; If all of the variables are deleted (have no references) when we
1338 ;;; are done, then we delete the LET.
1339 ;;;
1340 ;;; Note that we are responsible for clearing the LVAR-REOPTIMIZE
1341 ;;; flags.
1342 (defun propagate-let-args (call fun)
1343   (declare (type combination call) (type clambda fun))
1344   (loop for arg in (combination-args call)
1345         and var in (lambda-vars fun) do
1346     (when (and arg (lvar-reoptimize arg))
1347       (setf (lvar-reoptimize arg) nil)
1348       (cond
1349         ((lambda-var-sets var)
1350          (propagate-from-sets var (lvar-type arg)))
1351         ((let ((use (lvar-uses arg)))
1352            (when (ref-p use)
1353              (let ((leaf (ref-leaf use)))
1354                (when (and (constant-reference-p use)
1355                           (csubtypep (leaf-type leaf)
1356                                      ;; (NODE-DERIVED-TYPE USE) would
1357                                      ;; be better -- APD, 2003-05-15
1358                                      (leaf-type var)))
1359                  (propagate-to-refs var (lvar-type arg))
1360                  (let ((use-component (node-component use)))
1361                    (prog1 (substitute-leaf-if
1362                            (lambda (ref)
1363                              (cond ((eq (node-component ref) use-component)
1364                                     t)
1365                                    (t
1366                                     (aver (lambda-toplevelish-p (lambda-home fun)))
1367                                     nil)))
1368                            leaf var)))
1369                  t)))))
1370         ((and (null (rest (leaf-refs var)))
1371               (substitute-single-use-lvar arg var)))
1372         (t
1373          (propagate-to-refs var (lvar-type arg))))))
1374
1375   (when (every #'not (combination-args call))
1376     (delete-let fun))
1377
1378   (values))
1379
1380 ;;; This function is called when one of the args to a non-LET local
1381 ;;; call changes. For each changed argument corresponding to an unset
1382 ;;; variable, we compute the union of the types across all calls and
1383 ;;; propagate this type information to the var's refs.
1384 ;;;
1385 ;;; If the function has an XEP, then we don't do anything, since we
1386 ;;; won't discover anything.
1387 ;;;
1388 ;;; We can clear the LVAR-REOPTIMIZE flags for arguments in all calls
1389 ;;; corresponding to changed arguments in CALL, since the only use in
1390 ;;; IR1 optimization of the REOPTIMIZE flag for local call args is
1391 ;;; right here.
1392 (defun propagate-local-call-args (call fun)
1393   (declare (type combination call) (type clambda fun))
1394
1395   (unless (or (functional-entry-fun fun)
1396               (lambda-optional-dispatch fun))
1397     (let* ((vars (lambda-vars fun))
1398            (union (mapcar (lambda (arg var)
1399                             (when (and arg
1400                                        (lvar-reoptimize arg)
1401                                        (null (basic-var-sets var)))
1402                               (lvar-type arg)))
1403                           (basic-combination-args call)
1404                           vars))
1405            (this-ref (lvar-use (basic-combination-fun call))))
1406
1407       (dolist (arg (basic-combination-args call))
1408         (when arg
1409           (setf (lvar-reoptimize arg) nil)))
1410
1411       (dolist (ref (leaf-refs fun))
1412         (let ((dest (node-dest ref)))
1413           (unless (or (eq ref this-ref) (not dest))
1414             (setq union
1415                   (mapcar (lambda (this-arg old)
1416                             (when old
1417                               (setf (lvar-reoptimize this-arg) nil)
1418                               (type-union (lvar-type this-arg) old)))
1419                           (basic-combination-args dest)
1420                           union)))))
1421
1422       (loop for var in vars
1423             and type in union
1424             when type do (propagate-to-refs var type))))
1425
1426   (values))
1427 \f
1428 ;;;; multiple values optimization
1429
1430 ;;; Do stuff to notice a change to a MV combination node. There are
1431 ;;; two main branches here:
1432 ;;;  -- If the call is local, then it is already a MV let, or should
1433 ;;;     become one. Note that although all :LOCAL MV calls must eventually
1434 ;;;     be converted to :MV-LETs, there can be a window when the call
1435 ;;;     is local, but has not been LET converted yet. This is because
1436 ;;;     the entry-point lambdas may have stray references (in other
1437 ;;;     entry points) that have not been deleted yet.
1438 ;;;  -- The call is full. This case is somewhat similar to the non-MV
1439 ;;;     combination optimization: we propagate return type information and
1440 ;;;     notice non-returning calls. We also have an optimization
1441 ;;;     which tries to convert MV-CALLs into MV-binds.
1442 (defun ir1-optimize-mv-combination (node)
1443   (ecase (basic-combination-kind node)
1444     (:local
1445      (let ((fun-lvar (basic-combination-fun node)))
1446        (when (lvar-reoptimize fun-lvar)
1447          (setf (lvar-reoptimize fun-lvar) nil)
1448          (maybe-let-convert (combination-lambda node))))
1449      (setf (lvar-reoptimize (first (basic-combination-args node))) nil)
1450      (when (eq (functional-kind (combination-lambda node)) :mv-let)
1451        (unless (convert-mv-bind-to-let node)
1452          (ir1-optimize-mv-bind node))))
1453     (:full
1454      (let* ((fun (basic-combination-fun node))
1455             (fun-changed (lvar-reoptimize fun))
1456             (args (basic-combination-args node)))
1457        (when fun-changed
1458          (setf (lvar-reoptimize fun) nil)
1459          (let ((type (lvar-type fun)))
1460            (when (fun-type-p type)
1461              (derive-node-type node (fun-type-returns type))))
1462          (maybe-terminate-block node nil)
1463          (let ((use (lvar-uses fun)))
1464            (when (and (ref-p use) (functional-p (ref-leaf use)))
1465              (convert-call-if-possible use node)
1466              (when (eq (basic-combination-kind node) :local)
1467                (maybe-let-convert (ref-leaf use))))))
1468        (unless (or (eq (basic-combination-kind node) :local)
1469                    (eq (lvar-fun-name fun) '%throw))
1470          (ir1-optimize-mv-call node))
1471        (dolist (arg args)
1472          (setf (lvar-reoptimize arg) nil))))
1473     (:error))
1474   (values))
1475
1476 ;;; Propagate derived type info from the values lvar to the vars.
1477 (defun ir1-optimize-mv-bind (node)
1478   (declare (type mv-combination node))
1479   (let* ((arg (first (basic-combination-args node)))
1480          (vars (lambda-vars (combination-lambda node)))
1481          (n-vars (length vars))
1482          (types (values-type-in (lvar-derived-type arg)
1483                                 n-vars)))
1484     (loop for var in vars
1485           and type in types
1486           do (if (basic-var-sets var)
1487                  (propagate-from-sets var type)
1488                  (propagate-to-refs var type)))
1489     (setf (lvar-reoptimize arg) nil))
1490   (values))
1491
1492 ;;; If possible, convert a general MV call to an MV-BIND. We can do
1493 ;;; this if:
1494 ;;; -- The call has only one argument, and
1495 ;;; -- The function has a known fixed number of arguments, or
1496 ;;; -- The argument yields a known fixed number of values.
1497 ;;;
1498 ;;; What we do is change the function in the MV-CALL to be a lambda
1499 ;;; that "looks like an MV bind", which allows
1500 ;;; IR1-OPTIMIZE-MV-COMBINATION to notice that this call can be
1501 ;;; converted (the next time around.) This new lambda just calls the
1502 ;;; actual function with the MV-BIND variables as arguments. Note that
1503 ;;; this new MV bind is not let-converted immediately, as there are
1504 ;;; going to be stray references from the entry-point functions until
1505 ;;; they get deleted.
1506 ;;;
1507 ;;; In order to avoid loss of argument count checking, we only do the
1508 ;;; transformation according to a known number of expected argument if
1509 ;;; safety is unimportant. We can always convert if we know the number
1510 ;;; of actual values, since the normal call that we build will still
1511 ;;; do any appropriate argument count checking.
1512 ;;;
1513 ;;; We only attempt the transformation if the called function is a
1514 ;;; constant reference. This allows us to just splice the leaf into
1515 ;;; the new function, instead of trying to somehow bind the function
1516 ;;; expression. The leaf must be constant because we are evaluating it
1517 ;;; again in a different place. This also has the effect of squelching
1518 ;;; multiple warnings when there is an argument count error.
1519 (defun ir1-optimize-mv-call (node)
1520   (let ((fun (basic-combination-fun node))
1521         (*compiler-error-context* node)
1522         (ref (lvar-uses (basic-combination-fun node)))
1523         (args (basic-combination-args node)))
1524
1525     (unless (and (ref-p ref) (constant-reference-p ref)
1526                  (singleton-p args))
1527       (return-from ir1-optimize-mv-call))
1528
1529     (multiple-value-bind (min max)
1530         (fun-type-nargs (lvar-type fun))
1531       (let ((total-nvals
1532              (multiple-value-bind (types nvals)
1533                  (values-types (lvar-derived-type (first args)))
1534                (declare (ignore types))
1535                (if (eq nvals :unknown) nil nvals))))
1536
1537         (when total-nvals
1538           (when (and min (< total-nvals min))
1539             (compiler-warn
1540              "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
1541              at least ~R."
1542              total-nvals min)
1543             (setf (basic-combination-kind node) :error)
1544             (return-from ir1-optimize-mv-call))
1545           (when (and max (> total-nvals max))
1546             (compiler-warn
1547              "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
1548              at most ~R."
1549              total-nvals max)
1550             (setf (basic-combination-kind node) :error)
1551             (return-from ir1-optimize-mv-call)))
1552
1553         (let ((count (cond (total-nvals)
1554                            ((and (policy node (zerop verify-arg-count))
1555                                  (eql min max))
1556                             min)
1557                            (t nil))))
1558           (when count
1559             (with-ir1-environment-from-node node
1560               (let* ((dums (make-gensym-list count))
1561                      (ignore (gensym))
1562                      (fun (ir1-convert-lambda
1563                            `(lambda (&optional ,@dums &rest ,ignore)
1564                               (declare (ignore ,ignore))
1565                               (funcall ,(ref-leaf ref) ,@dums)))))
1566                 (change-ref-leaf ref fun)
1567                 (aver (eq (basic-combination-kind node) :full))
1568                 (locall-analyze-component *current-component*)
1569                 (aver (eq (basic-combination-kind node) :local)))))))))
1570   (values))
1571
1572 ;;; If we see:
1573 ;;;    (multiple-value-bind
1574 ;;;     (x y)
1575 ;;;     (values xx yy)
1576 ;;;      ...)
1577 ;;; Convert to:
1578 ;;;    (let ((x xx)
1579 ;;;       (y yy))
1580 ;;;      ...)
1581 ;;;
1582 ;;; What we actually do is convert the VALUES combination into a
1583 ;;; normal LET combination calling the original :MV-LET lambda. If
1584 ;;; there are extra args to VALUES, discard the corresponding
1585 ;;; lvars. If there are insufficient args, insert references to NIL.
1586 (defun convert-mv-bind-to-let (call)
1587   (declare (type mv-combination call))
1588   (let* ((arg (first (basic-combination-args call)))
1589          (use (lvar-uses arg)))
1590     (when (and (combination-p use)
1591                (eq (lvar-fun-name (combination-fun use))
1592                    'values))
1593       (let* ((fun (combination-lambda call))
1594              (vars (lambda-vars fun))
1595              (vals (combination-args use))
1596              (nvars (length vars))
1597              (nvals (length vals)))
1598         (cond ((> nvals nvars)
1599                (mapc #'flush-dest (subseq vals nvars))
1600                (setq vals (subseq vals 0 nvars)))
1601               ((< nvals nvars)
1602                (with-ir1-environment-from-node use
1603                  (let ((node-prev (node-prev use)))
1604                    (setf (node-prev use) nil)
1605                    (setf (ctran-next node-prev) nil)
1606                    (collect ((res vals))
1607                      (loop for count below (- nvars nvals)
1608                            for prev = node-prev then ctran
1609                            for ctran = (make-ctran)
1610                            and lvar = (make-lvar use)
1611                            do (reference-constant prev ctran lvar nil)
1612                               (res lvar)
1613                            finally (link-node-to-previous-ctran
1614                                     use ctran))
1615                      (setq vals (res)))))))
1616         (setf (combination-args use) vals)
1617         (flush-dest (combination-fun use))
1618         (let ((fun-lvar (basic-combination-fun call)))
1619           (setf (lvar-dest fun-lvar) use)
1620           (setf (combination-fun use) fun-lvar)
1621           (flush-lvar-externally-checkable-type fun-lvar))
1622         (setf (combination-kind use) :local)
1623         (setf (functional-kind fun) :let)
1624         (flush-dest (first (basic-combination-args call)))
1625         (unlink-node call)
1626         (when vals
1627           (reoptimize-lvar (first vals)))
1628         (propagate-to-args use fun)
1629         (reoptimize-call use))
1630       t)))
1631
1632 ;;; If we see:
1633 ;;;    (values-list (list x y z))
1634 ;;;
1635 ;;; Convert to:
1636 ;;;    (values x y z)
1637 ;;;
1638 ;;; In implementation, this is somewhat similar to
1639 ;;; CONVERT-MV-BIND-TO-LET. We grab the args of LIST and make them
1640 ;;; args of the VALUES-LIST call, flushing the old argument lvar
1641 ;;; (allowing the LIST to be flushed.)
1642 ;;;
1643 ;;; FIXME: Thus we lose possible type assertions on (LIST ...).
1644 (defoptimizer (values-list optimizer) ((list) node)
1645   (let ((use (lvar-uses list)))
1646     (when (and (combination-p use)
1647                (eq (lvar-fun-name (combination-fun use))
1648                    'list))
1649
1650       ;; FIXME: VALUES might not satisfy an assertion on NODE-LVAR.
1651       (change-ref-leaf (lvar-uses (combination-fun node))
1652                        (find-free-fun 'values "in a strange place"))
1653       (setf (combination-kind node) :full)
1654       (let ((args (combination-args use)))
1655         (dolist (arg args)
1656           (setf (lvar-dest arg) node)
1657           (flush-lvar-externally-checkable-type arg))
1658         (setf (combination-args use) nil)
1659         (flush-dest list)
1660         (setf (combination-args node) args))
1661       t)))
1662
1663 ;;; If VALUES appears in a non-MV context, then effectively convert it
1664 ;;; to a PROG1. This allows the computation of the additional values
1665 ;;; to become dead code.
1666 (deftransform values ((&rest vals) * * :node node)
1667   (unless (lvar-single-value-p (node-lvar node))
1668     (give-up-ir1-transform))
1669   (setf (node-derived-type node) *wild-type*)
1670   (principal-lvar-single-valuify (node-lvar node))
1671   (if vals
1672       (let ((dummies (make-gensym-list (length (cdr vals)))))
1673         `(lambda (val ,@dummies)
1674            (declare (ignore ,@dummies))
1675            val))
1676       nil))
1677
1678 ;;; TODO:
1679 ;;; - CAST chains;
1680 (defun ir1-optimize-cast (cast &optional do-not-optimize)
1681   (declare (type cast cast))
1682   (let* ((value (cast-value cast))
1683          (value-type (lvar-derived-type value))
1684          (atype (cast-asserted-type cast))
1685          (int (values-type-intersection value-type atype)))
1686     (derive-node-type cast int)
1687     (when (eq int *empty-type*)
1688       (unless (eq value-type *empty-type*)
1689
1690         ;; FIXME: Do it in one step.
1691         (filter-lvar
1692          value
1693          `(multiple-value-call #'list 'dummy))
1694         (filter-lvar
1695          (cast-value cast)
1696          ;; FIXME: Derived type.
1697          `(%compile-time-type-error 'dummy
1698                                     ',(type-specifier atype)
1699                                     ',(type-specifier value-type)))
1700         ;; KLUDGE: FILTER-LVAR does not work for non-returning
1701         ;; functions, so we declare the return type of
1702         ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
1703         ;; here.
1704         (setq value (cast-value cast))
1705         (derive-node-type (lvar-uses value) *empty-type*)
1706         (maybe-terminate-block (lvar-uses value) nil)
1707         ;; FIXME: Is it necessary?
1708         (aver (null (block-pred (node-block cast))))
1709         (setf (block-delete-p (node-block cast)) t)
1710         (return-from ir1-optimize-cast)))
1711     (when (eq (node-derived-type cast) *empty-type*)
1712       (maybe-terminate-block cast nil))
1713
1714     (when (not do-not-optimize)
1715       (let ((lvar (node-lvar cast)))
1716         (when (values-subtypep value-type (cast-asserted-type cast))
1717           (delete-filter cast lvar value)
1718           (when lvar
1719             (reoptimize-lvar lvar)
1720             (when (lvar-single-value-p lvar)
1721               (note-single-valuified-lvar lvar)))
1722           (return-from ir1-optimize-cast t))
1723
1724         (when (and (listp (lvar-uses value))
1725                    lvar)
1726           ;; Pathwise removing of CAST
1727           (let ((ctran (node-next cast))
1728                 (dest (lvar-dest lvar))
1729                 next-block)
1730             (collect ((merges))
1731               (do-uses (use value)
1732                 (when (and (values-subtypep (node-derived-type use) atype)
1733                            (immediately-used-p value use))
1734                   (unless next-block
1735                     (when ctran (ensure-block-start ctran))
1736                     (setq next-block (first (block-succ (node-block cast)))))
1737                   (%delete-lvar-use use)
1738                   (add-lvar-use use lvar)
1739                   (unlink-blocks (node-block use) (node-block cast))
1740                   (link-blocks (node-block use) next-block)
1741                   (when (and (return-p dest)
1742                              (basic-combination-p use)
1743                              (eq (basic-combination-kind use) :local))
1744                     (merges use))))
1745               (dolist (use (merges))
1746                 (merge-tail-sets use)))))))
1747
1748     (when (and (cast-%type-check cast)
1749                (values-subtypep value-type
1750                                 (cast-type-to-check cast)))
1751       (setf (cast-%type-check cast) nil)))
1752
1753   (unless do-not-optimize
1754     (setf (node-reoptimize cast) nil)))