src/compiler/ir2tran.lisp

   1 ;;;; This file contains the virtual-machine-independent parts of the
   2 ;;;; code which does the actual translation of nodes to VOPs.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!C")
  14 \f
  15 ;;;; moves and type checks
  16
  17 ;;; Move X to Y unless they are EQ.
  18 (defun emit-move (node block x y)
  19   (declare (type node node) (type ir2-block block) (type tn x y))
  20   (unless (eq x y)
  21     (vop move node block x y))
  22   (values))
  23
  24 ;;; Determine whether we should emit a single-stepper breakpoint
  25 ;;; around a call / before a vop.
  26 (defun emit-step-p (node)
  27   (if (and (policy node (> insert-step-conditions 1))
  28            (typep node 'combination))
  29       (combination-step-info node)
  30       nil))
  31
  32 ;;; If there is any CHECK-xxx template for TYPE, then return it,
  33 ;;; otherwise return NIL.
  34 (defun type-check-template (type)
  35   (declare (type ctype type))
  36   (multiple-value-bind (check-ptype exact) (primitive-type type)
  37     (if exact
  38         (primitive-type-check check-ptype)
  39         (let ((name (hairy-type-check-template-name type)))
  40           (if name
  41               (template-or-lose name)
  42               nil)))))
  43
  44 ;;; Emit code in BLOCK to check that VALUE is of the specified TYPE,
  45 ;;; yielding the checked result in RESULT. VALUE and result may be of
  46 ;;; any primitive type. There must be CHECK-xxx VOP for TYPE. Any
  47 ;;; other type checks should have been converted to an explicit type
  48 ;;; test.
  49 (defun emit-type-check (node block value result type)
  50   (declare (type tn value result) (type node node) (type ir2-block block)
  51            (type ctype type))
  52   (emit-move-template node block (type-check-template type) value result)
  53   (values))
  54
  55 ;;; Allocate an indirect value cell.
  56 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")
  57 (defun emit-make-value-cell (node block value res)
  58   (event make-value-cell-event node)
  59   (let ((leaf (tn-leaf res)))
  60     (vop make-value-cell node block value
  61          (and leaf (leaf-dynamic-extent leaf)
  62               ;; FIXME: See bug 419
  63               (policy node (> stack-allocate-value-cells 1)))
  64          res)))
  65 \f
  66 ;;;; leaf reference
  67
  68 ;;; Return the TN that holds the value of THING in the environment ENV.
  69 (declaim (ftype (function ((or nlx-info lambda-var clambda) physenv) tn)
  70                 find-in-physenv))
  71 (defun find-in-physenv (thing physenv)
  72   (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv))))
  73       (etypecase thing
  74         (lambda-var
  75          ;; I think that a failure of this assertion means that we're
  76          ;; trying to access a variable which was improperly closed
  77          ;; over. The PHYSENV describes a physical environment. Every
  78          ;; variable that a form refers to should either be in its
  79          ;; physical environment directly, or grabbed from a
  80          ;; surrounding physical environment when it was closed over.
  81          ;; The ASSOC expression above finds closed-over variables, so
  82          ;; if we fell through the ASSOC expression, it wasn't closed
  83          ;; over. Therefore, it must be in our physical environment
  84          ;; directly. If instead it is in some other physical
  85          ;; environment, then it's bogus for us to reference it here
  86          ;; without it being closed over. -- WHN 2001-09-29
  87          (aver (eq physenv (lambda-physenv (lambda-var-home thing))))
  88          (leaf-info thing))
  89         (nlx-info
  90          (aver (eq physenv (block-physenv (nlx-info-target thing))))
  91          (ir2-nlx-info-home (nlx-info-info thing)))
  92         (clambda
  93          (aver (xep-p thing))
  94          (entry-info-closure-tn (lambda-info thing))))
  95       (bug "~@<~2I~_~S ~_not found in ~_~S~:>" thing physenv)))
  96
  97 ;;; If LEAF already has a constant TN, return that, otherwise make a
  98 ;;; TN for it.
  99 (defun constant-tn (leaf)
 100   (declare (type constant leaf))
 101   (or (leaf-info leaf)
 102       (setf (leaf-info leaf)
 103             (make-constant-tn leaf))))
 104
 105 ;;; Return a TN that represents the value of LEAF, or NIL if LEAF
 106 ;;; isn't directly represented by a TN. ENV is the environment that
 107 ;;; the reference is done in.
 108 (defun leaf-tn (leaf env)
 109   (declare (type leaf leaf) (type physenv env))
 110   (typecase leaf
 111     (lambda-var
 112      (unless (lambda-var-indirect leaf)
 113        (find-in-physenv leaf env)))
 114     (constant (constant-tn leaf))
 115     (t nil)))
 116
 117 ;;; This is used to conveniently get a handle on a constant TN during
 118 ;;; IR2 conversion. It returns a constant TN representing the Lisp
 119 ;;; object VALUE.
 120 (defun emit-constant (value)
 121   (constant-tn (find-constant value)))
 122
 123 ;;; Convert a REF node. The reference must not be delayed.
 124 (defun ir2-convert-ref (node block)
 125   (declare (type ref node) (type ir2-block block))
 126   (let* ((lvar (node-lvar node))
 127          (leaf (ref-leaf node))
 128          (locs (lvar-result-tns
 129                 lvar (list (primitive-type (leaf-type leaf)))))
 130          (res (first locs)))
 131     (etypecase leaf
 132       (lambda-var
 133        (let ((tn (find-in-physenv leaf (node-physenv node))))
 134          (if (lambda-var-indirect leaf)
 135              (vop value-cell-ref node block tn res)
 136              (emit-move node block tn res))))
 137       (constant
 138        (emit-move node block (constant-tn leaf) res))
 139       (functional
 140        (ir2-convert-closure node block leaf res))
 141       (global-var
 142        (let ((unsafe (policy node (zerop safety)))
 143              (name (leaf-source-name leaf)))
 144          (ecase (global-var-kind leaf)
 145            ((:special :global)
 146             (aver (symbolp name))
 147             (let ((name-tn (emit-constant name)))
 148               (if unsafe
 149                   (vop fast-symbol-value node block name-tn res)
 150                   (vop symbol-value node block name-tn res))))
 151            (:global-function
 152             (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
 153               (if unsafe
 154                   (vop fdefn-fun node block fdefn-tn res)
 155                   (vop safe-fdefn-fun node block fdefn-tn res))))))))
 156     (move-lvar-result node block locs lvar))
 157   (values))
 158
 159 ;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE
 160 (defun assertions-on-ir2-converted-clambda (clambda)
 161   ;; This assertion was sort of an experiment. It would be nice and
 162   ;; sane and easier to understand things if it were *always* true,
 163   ;; but experimentally I observe that it's only *almost* always
 164   ;; true. -- WHN 2001-01-02
 165   #+nil
 166   (aver (eql (lambda-component clambda)
 167              (block-component (ir2-block-block ir2-block))))
 168   ;; Check for some weirdness which came up in bug
 169   ;; 138, 2002-01-02.
 170   ;;
 171   ;; The MAKE-LOAD-TIME-CONSTANT-TN call above puts an :ENTRY record
 172   ;; into the IR2-COMPONENT-CONSTANTS table. The dump-a-COMPONENT
 173   ;; code
 174   ;;   * treats every HANDLEless :ENTRY record into a
 175   ;;     patch, and
 176   ;;   * expects every patch to correspond to an
 177   ;;     IR2-COMPONENT-ENTRIES record.
 178   ;; The IR2-COMPONENT-ENTRIES records are set by ENTRY-ANALYZE
 179   ;; walking over COMPONENT-LAMBDAS. Bug 138b arose because there
 180   ;; was a HANDLEless :ENTRY record which didn't correspond to an
 181   ;; IR2-COMPONENT-ENTRIES record. That problem is hard to debug
 182   ;; when it's caught at dump time, so this assertion tries to catch
 183   ;; it here.
 184   (aver (member clambda
 185                 (component-lambdas (lambda-component clambda))))
 186   ;; another bug-138-related issue: COMPONENT-NEW-FUNCTIONALS is
 187   ;; used as a queue for stuff pending to do in IR1, and now that
 188   ;; we're doing IR2 it should've been completely flushed (but
 189   ;; wasn't).
 190   (aver (null (component-new-functionals (lambda-component clambda))))
 191   (values))
 192
 193 ;;; Emit code to load a function object implementing FUNCTIONAL into
 194 ;;; RES. This gets interesting when the referenced function is a
 195 ;;; closure: we must make the closure and move the closed-over values
 196 ;;; into it.
 197 ;;;
 198 ;;; FUNCTIONAL is either a :TOPLEVEL-XEP functional or the XEP lambda
 199 ;;; for the called function, since local call analysis converts all
 200 ;;; closure references. If a :TOPLEVEL-XEP, we know it is not a
 201 ;;; closure.
 202 ;;;
 203 ;;; If a closed-over LAMBDA-VAR has no refs (is deleted), then we
 204 ;;; don't initialize that slot. This can happen with closures over
 205 ;;; top level variables, where optimization of the closure deleted the
 206 ;;; variable. Since we committed to the closure format when we
 207 ;;; pre-analyzed the top level code, we just leave an empty slot.
 208 (defun ir2-convert-closure (ref ir2-block functional res)
 209   (declare (type ref ref)
 210            (type ir2-block ir2-block)
 211            (type functional functional)
 212            (type tn res))
 213   (aver (not (eql (functional-kind functional) :deleted)))
 214   (unless (leaf-info functional)
 215     (setf (leaf-info functional)
 216           (make-entry-info :name (functional-debug-name functional))))
 217   (let ((closure (etypecase functional
 218                    (clambda
 219                     (assertions-on-ir2-converted-clambda functional)
 220                     (physenv-closure (get-lambda-physenv functional)))
 221                    (functional
 222                     (aver (eq (functional-kind functional) :toplevel-xep))
 223                     nil))))
 224
 225     (cond (closure
 226            (let* ((physenv (node-physenv ref))
 227                   (tn (find-in-physenv functional physenv)))
 228              (emit-move ref ir2-block tn res)))
 229           (t
 230            (let ((entry (make-load-time-constant-tn :entry functional)))
 231              (emit-move ref ir2-block entry res)))))
 232   (values))
 233
 234 (defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy)
 235   ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
 236   (when (lvar-dynamic-extent leaves)
 237     (let ((info (make-ir2-lvar *backend-t-primitive-type*)))
 238       (setf (ir2-lvar-kind info) :delayed)
 239       (setf (lvar-info leaves) info)
 240       (setf (ir2-lvar-stack-pointer info)
 241             (make-stack-pointer-tn)))))
 242
 243 (defoptimizer (%allocate-closures ir2-convert) ((leaves) call 2block)
 244   (let ((dx-p (lvar-dynamic-extent leaves)))
 245     (collect ((delayed))
 246       (when dx-p
 247         (vop current-stack-pointer call 2block
 248              (ir2-lvar-stack-pointer (lvar-info leaves))))
 249       (dolist (leaf (lvar-value leaves))
 250         (binding* ((xep (functional-entry-fun leaf) :exit-if-null)
 251                    (nil (aver (xep-p xep)))
 252                    (entry-info (lambda-info xep) :exit-if-null)
 253                    (tn (entry-info-closure-tn entry-info) :exit-if-null)
 254                    (closure (physenv-closure (get-lambda-physenv xep)))
 255                    (entry (make-load-time-constant-tn :entry xep)))
 256           (let ((this-env (node-physenv call))
 257                 (leaf-dx-p (and dx-p (leaf-dynamic-extent leaf))))
 258             (vop make-closure call 2block entry (length closure)
 259                  leaf-dx-p tn)
 260             (loop for what in closure and n from 0 do
 261                   (unless (and (lambda-var-p what)
 262                                (null (leaf-refs what)))
 263                     ;; In LABELS a closure may refer to another closure
 264                     ;; in the same group, so we must be sure that we
 265                     ;; store a closure only after its creation.
 266                     ;;
 267                     ;; TODO: Here is a simple solution: we postpone
 268                     ;; putting of all closures after all creations
 269                     ;; (though it may require more registers).
 270                     (if (lambda-p what)
 271                         (delayed (list tn (find-in-physenv what this-env) n))
 272                         (vop closure-init call 2block
 273                              tn
 274                              (find-in-physenv what this-env)
 275                              n)))))))
 276       (loop for (tn what n) in (delayed)
 277             do (vop closure-init call 2block
 278                     tn what n))))
 279   (values))
 280
 281 ;;; Convert a SET node. If the NODE's LVAR is annotated, then we also
 282 ;;; deliver the value to that lvar. If the var is a lexical variable
 283 ;;; with no refs, then we don't actually set anything, since the
 284 ;;; variable has been deleted.
 285 (defun ir2-convert-set (node block)
 286   (declare (type cset node) (type ir2-block block))
 287   (let* ((lvar (node-lvar node))
 288          (leaf (set-var node))
 289          (val (lvar-tn node block (set-value node)))
 290          (locs (if lvar
 291                    (lvar-result-tns
 292                     lvar (list (primitive-type (leaf-type leaf))))
 293                    nil)))
 294     (etypecase leaf
 295       (lambda-var
 296        (when (leaf-refs leaf)
 297          (let ((tn (find-in-physenv leaf (node-physenv node))))
 298            (if (lambda-var-indirect leaf)
 299                (vop value-cell-set node block tn val)
 300                (emit-move node block val tn)))))
 301       (global-var
 302        (ecase (global-var-kind leaf)
 303          ((:special)
 304           (aver (symbolp (leaf-source-name leaf)))
 305           (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
 306     (when locs
 307       (emit-move node block val (first locs))
 308       (move-lvar-result node block locs lvar)))
 309   (values))
 310 \f
 311 ;;;; utilities for receiving fixed values
 312
 313 ;;; Return a TN that can be referenced to get the value of LVAR. LVAR
 314 ;;; must be LTN-ANNOTATED either as a delayed leaf ref or as a fixed,
 315 ;;; single-value lvar.
 316 ;;;
 317 ;;; The primitive-type of the result will always be the same as the
 318 ;;; IR2-LVAR-PRIMITIVE-TYPE, ensuring that VOPs are always called with
 319 ;;; TNs that satisfy the operand primitive-type restriction. We may
 320 ;;; have to make a temporary of the desired type and move the actual
 321 ;;; lvar TN into it. This happens when we delete a type check in
 322 ;;; unsafe code or when we locally know something about the type of an
 323 ;;; argument variable.
 324 (defun lvar-tn (node block lvar)
 325   (declare (type node node) (type ir2-block block) (type lvar lvar))
 326   (let* ((2lvar (lvar-info lvar))
 327          (lvar-tn
 328           (ecase (ir2-lvar-kind 2lvar)
 329             (:delayed
 330              (let ((ref (lvar-uses lvar)))
 331                (leaf-tn (ref-leaf ref) (node-physenv ref))))
 332             (:fixed
 333              (aver (= (length (ir2-lvar-locs 2lvar)) 1))
 334              (first (ir2-lvar-locs 2lvar)))))
 335          (ptype (ir2-lvar-primitive-type 2lvar)))
 336
 337     (cond ((eq (tn-primitive-type lvar-tn) ptype) lvar-tn)
 338           (t
 339            (let ((temp (make-normal-tn ptype)))
 340              (emit-move node block lvar-tn temp)
 341              temp)))))
 342
 343 ;;; This is similar to LVAR-TN, but hacks multiple values. We return
 344 ;;; TNs holding the values of LVAR with PTYPES as their primitive
 345 ;;; types. LVAR must be annotated for the same number of fixed values
 346 ;;; are there are PTYPES.
 347 ;;;
 348 ;;; If the lvar has a type check, check the values into temps and
 349 ;;; return the temps. When we have more values than assertions, we
 350 ;;; move the extra values with no check.
 351 (defun lvar-tns (node block lvar ptypes)
 352   (declare (type node node) (type ir2-block block)
 353            (type lvar lvar) (list ptypes))
 354   (let* ((locs (ir2-lvar-locs (lvar-info lvar)))
 355          (nlocs (length locs)))
 356     (aver (= nlocs (length ptypes)))
 357
 358     (mapcar (lambda (from to-type)
 359               (if (eq (tn-primitive-type from) to-type)
 360                   from
 361                   (let ((temp (make-normal-tn to-type)))
 362                     (emit-move node block from temp)
 363                     temp)))
 364             locs
 365             ptypes)))
 366 \f
 367 ;;;; utilities for delivering values to lvars
 368
 369 ;;; Return a list of TNs with the specifier TYPES that can be used as
 370 ;;; result TNs to evaluate an expression into LVAR. This is used
 371 ;;; together with MOVE-LVAR-RESULT to deliver fixed values to
 372 ;;; an lvar.
 373 ;;;
 374 ;;; If the lvar isn't annotated (meaning the values are discarded) or
 375 ;;; is unknown-values, the then we make temporaries for each supplied
 376 ;;; value, providing a place to compute the result in until we decide
 377 ;;; what to do with it (if anything.)
 378 ;;;
 379 ;;; If the lvar is fixed-values, and wants the same number of values
 380 ;;; as the user wants to deliver, then we just return the
 381 ;;; IR2-LVAR-LOCS. Otherwise we make a new list padded as necessary by
 382 ;;; discarded TNs. We always return a TN of the specified type, using
 383 ;;; the lvar locs only when they are of the correct type.
 384 (defun lvar-result-tns (lvar types)
 385   (declare (type (or lvar null) lvar) (type list types))
 386   (if (not lvar)
 387       (mapcar #'make-normal-tn types)
 388       (let ((2lvar (lvar-info lvar)))
 389         (ecase (ir2-lvar-kind 2lvar)
 390           (:fixed
 391            (let* ((locs (ir2-lvar-locs 2lvar))
 392                   (nlocs (length locs))
 393                   (ntypes (length types)))
 394              (if (and (= nlocs ntypes)
 395                       (do ((loc locs (cdr loc))
 396                            (type types (cdr type)))
 397                           ((null loc) t)
 398                         (unless (eq (tn-primitive-type (car loc)) (car type))
 399                           (return nil))))
 400                  locs
 401                  (mapcar (lambda (loc type)
 402                            (if (eq (tn-primitive-type loc) type)
 403                                loc
 404                                (make-normal-tn type)))
 405                          (if (< nlocs ntypes)
 406                              (append locs
 407                                      (mapcar #'make-normal-tn
 408                                              (subseq types nlocs)))
 409                              locs)
 410                          types))))
 411           (:unknown
 412            (mapcar #'make-normal-tn types))))))
 413
 414 ;;; Make the first N standard value TNs, returning them in a list.
 415 (defun make-standard-value-tns (n)
 416   (declare (type unsigned-byte n))
 417   (collect ((res))
 418     (dotimes (i n)
 419       (res (standard-arg-location i)))
 420     (res)))
 421
 422 ;;; Return a list of TNs wired to the standard value passing
 423 ;;; conventions that can be used to receive values according to the
 424 ;;; unknown-values convention. This is used with together
 425 ;;; MOVE-LVAR-RESULT for delivering unknown values to a fixed values
 426 ;;; lvar.
 427 ;;;
 428 ;;; If the lvar isn't annotated, then we treat as 0-values, returning
 429 ;;; an empty list of temporaries.
 430 ;;;
 431 ;;; If the lvar is annotated, then it must be :FIXED.
 432 (defun standard-result-tns (lvar)
 433   (declare (type (or lvar null) lvar))
 434   (if lvar
 435       (let ((2lvar (lvar-info lvar)))
 436         (ecase (ir2-lvar-kind 2lvar)
 437           (:fixed
 438            (make-standard-value-tns (length (ir2-lvar-locs 2lvar))))))
 439       nil))
 440
 441 ;;; Just move each SRC TN into the corresponding DEST TN, defaulting
 442 ;;; any unsupplied source values to NIL. We let EMIT-MOVE worry about
 443 ;;; doing the appropriate coercions.
 444 (defun move-results-coerced (node block src dest)
 445   (declare (type node node) (type ir2-block block) (list src dest))
 446   (let ((nsrc (length src))
 447         (ndest (length dest)))
 448     (mapc (lambda (from to)
 449             (unless (eq from to)
 450               (emit-move node block from to)))
 451           (if (> ndest nsrc)
 452               (append src (make-list (- ndest nsrc)
 453                                      :initial-element (emit-constant nil)))
 454               src)
 455           dest))
 456   (values))
 457
 458 ;;; Move each SRC TN into the corresponding DEST TN, checking types
 459 ;;; and defaulting any unsupplied source values to NIL
 460 (defun move-results-checked (node block src dest types)
 461   (declare (type node node) (type ir2-block block) (list src dest types))
 462   (let ((nsrc (length src))
 463         (ndest (length dest))
 464         (ntypes (length types)))
 465     (mapc (lambda (from to type)
 466             (if type
 467                 (emit-type-check node block from to type)
 468                 (emit-move node block from to)))
 469           (if (> ndest nsrc)
 470               (append src (make-list (- ndest nsrc)
 471                                      :initial-element (emit-constant nil)))
 472               src)
 473           dest
 474           (if (> ndest ntypes)
 475               (append types (make-list (- ndest ntypes)))
 476               types)))
 477   (values))
 478
 479 ;;; If necessary, emit coercion code needed to deliver the RESULTS to
 480 ;;; the specified lvar. NODE and BLOCK provide context for emitting
 481 ;;; code. Although usually obtained from STANDARD-RESULT-TNs or
 482 ;;; LVAR-RESULT-TNs, RESULTS my be a list of any type or
 483 ;;; number of TNs.
 484 ;;;
 485 ;;; If the lvar is fixed values, then move the results into the lvar
 486 ;;; locations. If the lvar is unknown values, then do the moves into
 487 ;;; the standard value locations, and use PUSH-VALUES to put the
 488 ;;; values on the stack.
 489 (defun move-lvar-result (node block results lvar)
 490   (declare (type node node) (type ir2-block block)
 491            (list results) (type (or lvar null) lvar))
 492   (when lvar
 493     (let ((2lvar (lvar-info lvar)))
 494       (ecase (ir2-lvar-kind 2lvar)
 495         (:fixed
 496          (let ((locs (ir2-lvar-locs 2lvar)))
 497            (unless (eq locs results)
 498              (move-results-coerced node block results locs))))
 499         (:unknown
 500          (let* ((nvals (length results))
 501                 (locs (make-standard-value-tns nvals)))
 502            (move-results-coerced node block results locs)
 503            (vop* push-values node block
 504                  ((reference-tn-list locs nil))
 505                  ((reference-tn-list (ir2-lvar-locs 2lvar) t))
 506                  nvals))))))
 507   (values))
 508
 509 ;;; CAST
 510 (defun ir2-convert-cast (node block)
 511   (declare (type cast node)
 512            (type ir2-block block))
 513   (binding* ((lvar (node-lvar node) :exit-if-null)
 514              (2lvar (lvar-info lvar))
 515              (value (cast-value node))
 516              (2value (lvar-info value)))
 517     (cond ((eq (ir2-lvar-kind 2lvar) :unused))
 518           ((eq (ir2-lvar-kind 2lvar) :unknown)
 519            (aver (eq (ir2-lvar-kind 2value) :unknown))
 520            (aver (not (cast-type-check node)))
 521            (move-results-coerced node block
 522                                  (ir2-lvar-locs 2value)
 523                                  (ir2-lvar-locs 2lvar)))
 524           ((eq (ir2-lvar-kind 2lvar) :fixed)
 525            (aver (eq (ir2-lvar-kind 2value) :fixed))
 526            (if (cast-type-check node)
 527                (move-results-checked node block
 528                                      (ir2-lvar-locs 2value)
 529                                      (ir2-lvar-locs 2lvar)
 530                                      (multiple-value-bind (check types)
 531                                          (cast-check-types node nil)
 532                                        (aver (eq check :simple))
 533                                        types))
 534                (move-results-coerced node block
 535                                      (ir2-lvar-locs 2value)
 536                                      (ir2-lvar-locs 2lvar))))
 537           (t (bug "CAST cannot be :DELAYED.")))))
 538 \f
 539 ;;;; template conversion
 540
 541 ;;; Build a TN-REFS list that represents access to the values of the
 542 ;;; specified list of lvars ARGS for TEMPLATE. Any :CONSTANT arguments
 543 ;;; are returned in the second value as a list rather than being
 544 ;;; accessed as a normal argument. NODE and BLOCK provide the context
 545 ;;; for emitting any necessary type-checking code.
 546 (defun reference-args (node block args template)
 547   (declare (type node node) (type ir2-block block) (list args)
 548            (type template template))
 549   (collect ((info-args))
 550     (let ((last nil)
 551           (first nil))
 552       (do ((args args (cdr args))
 553            (types (template-arg-types template) (cdr types)))
 554           ((null args))
 555         (let ((type (first types))
 556               (arg (first args)))
 557           (if (and (consp type) (eq (car type) ':constant))
 558               (info-args (lvar-value arg))
 559               (let ((ref (reference-tn (lvar-tn node block arg) nil)))
 560                 (if last
 561                     (setf (tn-ref-across last) ref)
 562                     (setf first ref))
 563                 (setq last ref)))))
 564
 565       (values (the (or tn-ref null) first) (info-args)))))
 566
 567 ;;; Convert a conditional template. We try to exploit any
 568 ;;; drop-through, but emit an unconditional branch afterward if we
 569 ;;; fail. NOT-P is true if the sense of the TEMPLATE's test should be
 570 ;;; negated.
 571 (defun ir2-convert-conditional (node block template args info-args if not-p)
 572   (declare (type node node) (type ir2-block block)
 573            (type template template) (type (or tn-ref null) args)
 574            (list info-args) (type cif if) (type boolean not-p))
 575   (aver (= (template-info-arg-count template) (+ (length info-args) 2)))
 576   (let ((consequent (if-consequent if))
 577         (alternative (if-alternative if)))
 578     (cond ((drop-thru-p if consequent)
 579            (emit-template node block template args nil
 580                           (list* (block-label alternative) (not not-p)
 581                                  info-args)))
 582           (t
 583            (emit-template node block template args nil
 584                           (list* (block-label consequent) not-p info-args))
 585            (unless (drop-thru-p if alternative)
 586              (vop branch node block (block-label alternative)))))))
 587
 588 ;;; Convert an IF that isn't the DEST of a conditional template.
 589 (defun ir2-convert-if (node block)
 590   (declare (type ir2-block block) (type cif node))
 591   (let* ((test (if-test node))
 592          (test-ref (reference-tn (lvar-tn node block test) nil))
 593          (nil-ref (reference-tn (emit-constant nil) nil)))
 594     (setf (tn-ref-across test-ref) nil-ref)
 595     (ir2-convert-conditional node block (template-or-lose 'if-eq)
 596                              test-ref () node t)))
 597
 598 ;;; Return a list of primitive-types that we can pass to LVAR-RESULT-TNS
 599 ;;; describing the result types we want for a template call. We are really
 600 ;;; only interested in the number of results required: in normal case
 601 ;;; TEMPLATE-RESULTS-OK has already checked them.
 602 (defun find-template-result-types (call rtypes)
 603   (let* ((type (node-derived-type call))
 604          (types
 605           (mapcar #'primitive-type
 606                   (if (values-type-p type)
 607                       (append (args-type-required type)
 608                               (args-type-optional type))
 609                       (list type))))
 610          (primitive-t *backend-t-primitive-type*))
 611     (loop for rtype in rtypes
 612           for type = (or (pop types) primitive-t)
 613           collect type)))
 614
 615 ;;; Return a list of TNs usable in a CALL to TEMPLATE delivering values to
 616 ;;; LVAR. As an efficiency hack, we pick off the common case where the LVAR is
 617 ;;; fixed values and has locations that satisfy the result restrictions. This
 618 ;;; can fail when there is a type check or a values count mismatch.
 619 (defun make-template-result-tns (call lvar rtypes)
 620   (declare (type combination call) (type (or lvar null) lvar)
 621            (list rtypes))
 622   (let ((2lvar (when lvar (lvar-info lvar))))
 623     (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed))
 624         (let ((locs (ir2-lvar-locs 2lvar)))
 625           (if (and (= (length rtypes) (length locs))
 626                    (do ((loc locs (cdr loc))
 627                         (rtypes rtypes (cdr rtypes)))
 628                        ((null loc) t)
 629                      (unless (operand-restriction-ok
 630                               (car rtypes)
 631                               (tn-primitive-type (car loc))
 632                               :t-ok nil)
 633                        (return nil))))
 634               locs
 635               (lvar-result-tns
 636                lvar
 637                (find-template-result-types call rtypes))))
 638         (lvar-result-tns
 639          lvar
 640          (find-template-result-types call rtypes)))))
 641
 642 ;;; Get the operands into TNs, make TN-REFs for them, and then call
 643 ;;; the template emit function.
 644 (defun ir2-convert-template (call block)
 645   (declare (type combination call) (type ir2-block block))
 646   (let* ((template (combination-info call))
 647          (lvar (node-lvar call))
 648          (rtypes (template-result-types template)))
 649     (multiple-value-bind (args info-args)
 650         (reference-args call block (combination-args call) template)
 651       (aver (not (template-more-results-type template)))
 652       (if (eq rtypes :conditional)
 653           (ir2-convert-conditional call block template args info-args
 654                                    (lvar-dest lvar) nil)
 655           (let* ((results (make-template-result-tns call lvar rtypes))
 656                  (r-refs (reference-tn-list results t)))
 657             (aver (= (length info-args)
 658                      (template-info-arg-count template)))
 659             (when (and lvar (lvar-dynamic-extent lvar))
 660               (vop current-stack-pointer call block
 661                    (ir2-lvar-stack-pointer (lvar-info lvar))))
 662             (when (emit-step-p call)
 663               (vop sb!vm::step-instrument-before-vop call block))
 664             (if info-args
 665                 (emit-template call block template args r-refs info-args)
 666                 (emit-template call block template args r-refs))
 667             (move-lvar-result call block results lvar)))))
 668   (values))
 669
 670 ;;; We don't have to do much because operand count checking is done by
 671 ;;; IR1 conversion. The only difference between this and the function
 672 ;;; case of IR2-CONVERT-TEMPLATE is that there can be codegen-info
 673 ;;; arguments.
 674 (defoptimizer (%%primitive ir2-convert) ((template info &rest args) call block)
 675   (let* ((template (lvar-value template))
 676          (info (lvar-value info))
 677          (lvar (node-lvar call))
 678          (rtypes (template-result-types template))
 679          (results (make-template-result-tns call lvar rtypes))
 680          (r-refs (reference-tn-list results t)))
 681     (multiple-value-bind (args info-args)
 682         (reference-args call block (cddr (combination-args call)) template)
 683       (aver (not (template-more-results-type template)))
 684       (aver (not (eq rtypes :conditional)))
 685       (aver (null info-args))
 686
 687       (if info
 688           (emit-template call block template args r-refs info)
 689           (emit-template call block template args r-refs))
 690
 691       (move-lvar-result call block results lvar)))
 692   (values))
 693
 694 (defoptimizer (%%primitive derive-type) ((template info &rest args))
 695   (let ((type (template-type (lvar-value template))))
 696     (if (fun-type-p type)
 697         (fun-type-returns type)
 698         *wild-type*)))
 699 \f
 700 ;;;; local call
 701
 702 ;;; Convert a LET by moving the argument values into the variables.
 703 ;;; Since a LET doesn't have any passing locations, we move the
 704 ;;; arguments directly into the variables. We must also allocate any
 705 ;;; indirect value cells, since there is no function prologue to do
 706 ;;; this.
 707 (defun ir2-convert-let (node block fun)
 708   (declare (type combination node) (type ir2-block block) (type clambda fun))
 709   (mapc (lambda (var arg)
 710           (when arg
 711             (let ((src (lvar-tn node block arg))
 712                   (dest (leaf-info var)))
 713               (if (lambda-var-indirect var)
 714                   (emit-make-value-cell node block src dest)
 715                   (emit-move node block src dest)))))
 716         (lambda-vars fun) (basic-combination-args node))
 717   (values))
 718
 719 ;;; Emit any necessary moves into assignment temps for a local call to
 720 ;;; FUN. We return two lists of TNs: TNs holding the actual argument
 721 ;;; values, and (possibly EQ) TNs that are the actual destination of
 722 ;;; the arguments. When necessary, we allocate temporaries for
 723 ;;; arguments to preserve parallel assignment semantics. These lists
 724 ;;; exclude unused arguments and include implicit environment
 725 ;;; arguments, i.e. they exactly correspond to the arguments passed.
 726 ;;;
 727 ;;; OLD-FP is the TN currently holding the value we want to pass as
 728 ;;; OLD-FP. If null, then the call is to the same environment (an
 729 ;;; :ASSIGNMENT), so we only move the arguments, and leave the
 730 ;;; environment alone.
 731 (defun emit-psetq-moves (node block fun old-fp)
 732   (declare (type combination node) (type ir2-block block) (type clambda fun)
 733            (type (or tn null) old-fp))
 734   (let ((actuals (mapcar (lambda (x)
 735                            (when x
 736                              (lvar-tn node block x)))
 737                          (combination-args node))))
 738     (collect ((temps)
 739               (locs))
 740       (dolist (var (lambda-vars fun))
 741         (let ((actual (pop actuals))
 742               (loc (leaf-info var)))
 743           (when actual
 744             (cond
 745              ((lambda-var-indirect var)
 746               (let ((temp
 747                      (make-normal-tn *backend-t-primitive-type*)))
 748                 (emit-make-value-cell node block actual temp)
 749                 (temps temp)))
 750              ((member actual (locs))
 751               (let ((temp (make-normal-tn (tn-primitive-type loc))))
 752                 (emit-move node block actual temp)
 753                 (temps temp)))
 754              (t
 755               (temps actual)))
 756             (locs loc))))
 757
 758       (when old-fp
 759         (let ((this-1env (node-physenv node))
 760               (called-env (physenv-info (lambda-physenv fun))))
 761           (dolist (thing (ir2-physenv-closure called-env))
 762             (temps (find-in-physenv (car thing) this-1env))
 763             (locs (cdr thing)))
 764           (temps old-fp)
 765           (locs (ir2-physenv-old-fp called-env))))
 766
 767       (values (temps) (locs)))))
 768
 769 ;;; A tail-recursive local call is done by emitting moves of stuff
 770 ;;; into the appropriate passing locations. After setting up the args
 771 ;;; and environment, we just move our return-pc into the called
 772 ;;; function's passing location.
 773 (defun ir2-convert-tail-local-call (node block fun)
 774   (declare (type combination node) (type ir2-block block) (type clambda fun))
 775   (let ((this-env (physenv-info (node-physenv node))))
 776     (multiple-value-bind (temps locs)
 777         (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env))
 778
 779       (mapc (lambda (temp loc)
 780               (emit-move node block temp loc))
 781             temps locs))
 782
 783     (emit-move node block
 784                (ir2-physenv-return-pc this-env)
 785                (ir2-physenv-return-pc-pass
 786                 (physenv-info
 787                  (lambda-physenv fun)))))
 788
 789   (values))
 790
 791 ;;; Convert an :ASSIGNMENT call. This is just like a tail local call,
 792 ;;; except that the caller and callee environment are the same, so we
 793 ;;; don't need to mess with the environment locations, return PC, etc.
 794 (defun ir2-convert-assignment (node block fun)
 795   (declare (type combination node) (type ir2-block block) (type clambda fun))
 796     (multiple-value-bind (temps locs) (emit-psetq-moves node block fun nil)
 797
 798       (mapc (lambda (temp loc)
 799               (emit-move node block temp loc))
 800             temps locs))
 801   (values))
 802
 803 ;;; Do stuff to set up the arguments to a non-tail local call
 804 ;;; (including implicit environment args.) We allocate a frame
 805 ;;; (returning the FP and NFP), and also compute the TN-REFS list for
 806 ;;; the values to pass and the list of passing location TNs.
 807 (defun ir2-convert-local-call-args (node block fun)
 808   (declare (type combination node) (type ir2-block block) (type clambda fun))
 809   (let ((fp (make-stack-pointer-tn))
 810         (nfp (make-number-stack-pointer-tn))
 811         (old-fp (make-stack-pointer-tn)))
 812     (multiple-value-bind (temps locs)
 813         (emit-psetq-moves node block fun old-fp)
 814       (vop current-fp node block old-fp)
 815       (vop allocate-frame node block
 816            (physenv-info (lambda-physenv fun))
 817            fp nfp)
 818       (values fp nfp temps (mapcar #'make-alias-tn locs)))))
 819
 820 ;;; Handle a non-TR known-values local call. We emit the call, then
 821 ;;; move the results to the lvar's destination.
 822 (defun ir2-convert-local-known-call (node block fun returns lvar start)
 823   (declare (type node node) (type ir2-block block) (type clambda fun)
 824            (type return-info returns) (type (or lvar null) lvar)
 825            (type label start))
 826   (multiple-value-bind (fp nfp temps arg-locs)
 827       (ir2-convert-local-call-args node block fun)
 828     (let ((locs (return-info-locations returns)))
 829       (vop* known-call-local node block
 830             (fp nfp (reference-tn-list temps nil))
 831             ((reference-tn-list locs t))
 832             arg-locs (physenv-info (lambda-physenv fun)) start)
 833       (move-lvar-result node block locs lvar)))
 834   (values))
 835
 836 ;;; Handle a non-TR unknown-values local call. We do different things
 837 ;;; depending on what kind of values the lvar wants.
 838 ;;;
 839 ;;; If LVAR is :UNKNOWN, then we use the "multiple-" variant, directly
 840 ;;; specifying the lvar's LOCS as the VOP results so that we don't
 841 ;;; have to do anything after the call.
 842 ;;;
 843 ;;; Otherwise, we use STANDARD-RESULT-TNS to get wired result TNs, and
 844 ;;; then call MOVE-LVAR-RESULT to do any necessary type checks or
 845 ;;; coercions.
 846 (defun ir2-convert-local-unknown-call (node block fun lvar start)
 847   (declare (type node node) (type ir2-block block) (type clambda fun)
 848            (type (or lvar null) lvar) (type label start))
 849   (multiple-value-bind (fp nfp temps arg-locs)
 850       (ir2-convert-local-call-args node block fun)
 851     (let ((2lvar (and lvar (lvar-info lvar)))
 852           (env (physenv-info (lambda-physenv fun)))
 853           (temp-refs (reference-tn-list temps nil)))
 854       (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown))
 855           (vop* multiple-call-local node block (fp nfp temp-refs)
 856                 ((reference-tn-list (ir2-lvar-locs 2lvar) t))
 857                 arg-locs env start)
 858           (let ((locs (standard-result-tns lvar)))
 859             (vop* call-local node block
 860                   (fp nfp temp-refs)
 861                   ((reference-tn-list locs t))
 862                   arg-locs env start (length locs))
 863             (move-lvar-result node block locs lvar)))))
 864   (values))
 865
 866 ;;; Dispatch to the appropriate function, depending on whether we have
 867 ;;; a let, tail or normal call. If the function doesn't return, call
 868 ;;; it using the unknown-value convention. We could compile it as a
 869 ;;; tail call, but that might seem confusing in the debugger.
 870 (defun ir2-convert-local-call (node block)
 871   (declare (type combination node) (type ir2-block block))
 872   (let* ((fun (ref-leaf (lvar-uses (basic-combination-fun node))))
 873          (kind (functional-kind fun)))
 874     (cond ((eq kind :let)
 875            (ir2-convert-let node block fun))
 876           ((eq kind :assignment)
 877            (ir2-convert-assignment node block fun))
 878           ((node-tail-p node)
 879            (ir2-convert-tail-local-call node block fun))
 880           (t
 881            (let ((start (block-label (lambda-block fun)))
 882                  (returns (tail-set-info (lambda-tail-set fun)))
 883                  (lvar (node-lvar node)))
 884              (ecase (if returns
 885                         (return-info-kind returns)
 886                         :unknown)
 887                (:unknown
 888                 (ir2-convert-local-unknown-call node block fun lvar start))
 889                (:fixed
 890                 (ir2-convert-local-known-call node block fun returns
 891                                               lvar start)))))))
 892   (values))
 893 \f
 894 ;;;; full call
 895
 896 ;;; Given a function lvar FUN, return (VALUES TN-TO-CALL NAMED-P),
 897 ;;; where TN-TO-CALL is a TN holding the thing that we call NAMED-P is
 898 ;;; true if the thing is named (false if it is a function).
 899 ;;;
 900 ;;; There are two interesting non-named cases:
 901 ;;;   -- We know it's a function. No check needed: return the
 902 ;;;      lvar LOC.
 903 ;;;   -- We don't know what it is.
 904 (defun fun-lvar-tn (node block lvar)
 905   (declare (ignore node block))
 906   (declare (type lvar lvar))
 907   (let ((2lvar (lvar-info lvar)))
 908     (if (eq (ir2-lvar-kind 2lvar) :delayed)
 909         (let ((name (lvar-fun-name lvar t)))
 910           (aver name)
 911           (values (make-load-time-constant-tn :fdefinition name) t))
 912         (let* ((locs (ir2-lvar-locs 2lvar))
 913                (loc (first locs))
 914                (function-ptype (primitive-type-or-lose 'function)))
 915           (aver (and (eq (ir2-lvar-kind 2lvar) :fixed)
 916                      (= (length locs) 1)))
 917           (aver (eq (tn-primitive-type loc) function-ptype))
 918           (values loc nil)))))
 919
 920 ;;; Set up the args to NODE in the current frame, and return a TN-REF
 921 ;;; list for the passing locations.
 922 (defun move-tail-full-call-args (node block)
 923   (declare (type combination node) (type ir2-block block))
 924   (let ((args (basic-combination-args node))
 925         (last nil)
 926         (first nil))
 927     (dotimes (num (length args))
 928       (let ((loc (standard-arg-location num)))
 929         (emit-move node block (lvar-tn node block (elt args num)) loc)
 930         (let ((ref (reference-tn loc nil)))
 931           (if last
 932               (setf (tn-ref-across last) ref)
 933               (setf first ref))
 934           (setq last ref))))
 935       first))
 936
 937 ;;; Move the arguments into the passing locations and do a (possibly
 938 ;;; named) tail call.
 939 (defun ir2-convert-tail-full-call (node block)
 940   (declare (type combination node) (type ir2-block block))
 941   (let* ((env (physenv-info (node-physenv node)))
 942          (args (basic-combination-args node))
 943          (nargs (length args))
 944          (pass-refs (move-tail-full-call-args node block))
 945          (old-fp (ir2-physenv-old-fp env))
 946          (return-pc (ir2-physenv-return-pc env)))
 947
 948     (multiple-value-bind (fun-tn named)
 949         (fun-lvar-tn node block (basic-combination-fun node))
 950       (if named
 951           (vop* tail-call-named node block
 952                 (fun-tn old-fp return-pc pass-refs)
 953                 (nil)
 954                 nargs
 955                 (emit-step-p node))
 956           (vop* tail-call node block
 957                 (fun-tn old-fp return-pc pass-refs)
 958                 (nil)
 959                 nargs
 960                 (emit-step-p node)))))
 961
 962   (values))
 963
 964 ;;; like IR2-CONVERT-LOCAL-CALL-ARGS, only different
 965 (defun ir2-convert-full-call-args (node block)
 966   (declare (type combination node) (type ir2-block block))
 967   (let* ((args (basic-combination-args node))
 968          (fp (make-stack-pointer-tn))
 969          (nargs (length args)))
 970     (vop allocate-full-call-frame node block nargs fp)
 971     (collect ((locs))
 972       (let ((last nil)
 973             (first nil))
 974         (dotimes (num nargs)
 975           (locs (standard-arg-location num))
 976           (let ((ref (reference-tn (lvar-tn node block (elt args num))
 977                                    nil)))
 978             (if last
 979                 (setf (tn-ref-across last) ref)
 980                 (setf first ref))
 981             (setq last ref)))
 982
 983         (values fp first (locs) nargs)))))
 984
 985 ;;; Do full call when a fixed number of values are desired. We make
 986 ;;; STANDARD-RESULT-TNS for our lvar, then deliver the result using
 987 ;;; MOVE-LVAR-RESULT. We do named or normal call, as appropriate.
 988 (defun ir2-convert-fixed-full-call (node block)
 989   (declare (type combination node) (type ir2-block block))
 990   (multiple-value-bind (fp args arg-locs nargs)
 991       (ir2-convert-full-call-args node block)
 992     (let* ((lvar (node-lvar node))
 993            (locs (standard-result-tns lvar))
 994            (loc-refs (reference-tn-list locs t))
 995            (nvals (length locs)))
 996       (multiple-value-bind (fun-tn named)
 997           (fun-lvar-tn node block (basic-combination-fun node))
 998         (if named
 999             (vop* call-named node block (fp fun-tn args) (loc-refs)
1000                   arg-locs nargs nvals (emit-step-p node))
1001             (vop* call node block (fp fun-tn args) (loc-refs)
1002                   arg-locs nargs nvals (emit-step-p node)))
1003         (move-lvar-result node block locs lvar))))
1004   (values))
1005
1006 ;;; Do full call when unknown values are desired.
1007 (defun ir2-convert-multiple-full-call (node block)
1008   (declare (type combination node) (type ir2-block block))
1009   (multiple-value-bind (fp args arg-locs nargs)
1010       (ir2-convert-full-call-args node block)
1011     (let* ((lvar (node-lvar node))
1012            (locs (ir2-lvar-locs (lvar-info lvar)))
1013            (loc-refs (reference-tn-list locs t)))
1014       (multiple-value-bind (fun-tn named)
1015           (fun-lvar-tn node block (basic-combination-fun node))
1016         (if named
1017             (vop* multiple-call-named node block (fp fun-tn args) (loc-refs)
1018                   arg-locs nargs (emit-step-p node))
1019             (vop* multiple-call node block (fp fun-tn args) (loc-refs)
1020                   arg-locs nargs (emit-step-p node))))))
1021   (values))
1022
1023 ;;; stuff to check in PONDER-FULL-CALL
1024 ;;;
1025 ;;; These came in handy when troubleshooting cold boot after making
1026 ;;; major changes in the package structure: various transforms and
1027 ;;; VOPs and stuff got attached to the wrong symbol, so that
1028 ;;; references to the right symbol were bogusly translated as full
1029 ;;; calls instead of primitives, sending the system off into infinite
1030 ;;; space. Having a report on all full calls generated makes it easier
1031 ;;; to figure out what form caused the problem this time.
1032 #!+sb-show (defvar *show-full-called-fnames-p* nil)
1033 #!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal))
1034
1035 ;;; Do some checks (and store some notes relevant for future checks)
1036 ;;; on a full call:
1037 ;;;   * Is this a full call to something we have reason to know should
1038 ;;;     never be full called? (Except as of sbcl-0.7.18 or so, we no
1039 ;;;     longer try to ensure this behavior when *FAILURE-P* has already
1040 ;;;     been detected.)
1041 ;;;   * Is this a full call to (SETF FOO) which might conflict with
1042 ;;;     a DEFSETF or some such thing elsewhere in the program?
1043 (defun ponder-full-call (node)
1044   (let* ((lvar (basic-combination-fun node))
1045          (fname (lvar-fun-name lvar t)))
1046     (declare (type (or symbol cons) fname))
1047
1048     #!+sb-show (unless (gethash fname *full-called-fnames*)
1049                  (setf (gethash fname *full-called-fnames*) t))
1050     #!+sb-show (when *show-full-called-fnames-p*
1051                  (/show "converting full call to named function" fname)
1052                  (/show (basic-combination-args node))
1053                  (/show (policy node speed) (policy node safety))
1054                  (/show (policy node compilation-speed))
1055                  (let ((arg-types (mapcar (lambda (lvar)
1056                                             (when lvar
1057                                               (type-specifier
1058                                                (lvar-type lvar))))
1059                                           (basic-combination-args node))))
1060                    (/show arg-types)))
1061
1062     ;; When illegal code is compiled, all sorts of perverse paths
1063     ;; through the compiler can be taken, and it's much harder -- and
1064     ;; probably pointless -- to guarantee that always-optimized-away
1065     ;; functions are actually optimized away. Thus, we skip the check
1066     ;; in that case.
1067     (unless *failure-p*
1068       ;; check to see if we know anything about the function
1069       (let ((info (info :function :info fname)))
1070         ;; if we know something, check to see if the full call was valid
1071         (when (and info (ir1-attributep (fun-info-attributes info)
1072                                         always-translatable))
1073           (/show (policy node speed) (policy node safety))
1074           (/show (policy node compilation-speed))
1075           (bug "full call to ~S" fname))))
1076
1077     (when (consp fname)
1078       (aver (legal-fun-name-p fname))
1079       (destructuring-bind (setfoid &rest stem) fname
1080         (when (eq setfoid 'setf)
1081           (setf (gethash (car stem) *setf-assumed-fboundp*) t))))))
1082
1083 ;;; If the call is in a tail recursive position and the return
1084 ;;; convention is standard, then do a tail full call. If one or fewer
1085 ;;; values are desired, then use a single-value call, otherwise use a
1086 ;;; multiple-values call.
1087 (defun ir2-convert-full-call (node block)
1088   (declare (type combination node) (type ir2-block block))
1089   (ponder-full-call node)
1090   (cond ((node-tail-p node)
1091          (ir2-convert-tail-full-call node block))
1092         ((let ((lvar (node-lvar node)))
1093            (and lvar
1094                 (eq (ir2-lvar-kind (lvar-info lvar)) :unknown)))
1095          (ir2-convert-multiple-full-call node block))
1096         (t
1097          (ir2-convert-fixed-full-call node block)))
1098   (values))
1099 \f
1100 ;;;; entering functions
1101
1102 ;;; Do all the stuff that needs to be done on XEP entry:
1103 ;;; -- Create frame.
1104 ;;; -- Copy any more arg.
1105 ;;; -- Set up the environment, accessing any closure variables.
1106 ;;; -- Move args from the standard passing locations to their internal
1107 ;;;    locations.
1108 (defun init-xep-environment (node block fun)
1109   (declare (type bind node) (type ir2-block block) (type clambda fun))
1110   (let ((start-label (entry-info-offset (leaf-info fun)))
1111         (env (physenv-info (node-physenv node))))
1112     (let ((ef (functional-entry-fun fun)))
1113       (cond ((and (optional-dispatch-p ef) (optional-dispatch-more-entry ef))
1114              ;; Special case the xep-allocate-frame + copy-more-arg case.
1115              (vop xep-allocate-frame node block start-label t)
1116              (vop copy-more-arg node block (optional-dispatch-max-args ef)))
1117             (t
1118              ;; No more args, so normal entry.
1119              (vop xep-allocate-frame node block start-label nil)))
1120       (if (ir2-physenv-closure env)
1121           (let ((closure (make-normal-tn *backend-t-primitive-type*)))
1122             (vop setup-closure-environment node block start-label closure)
1123             (let ((n -1))
1124               (dolist (loc (ir2-physenv-closure env))
1125                 (vop closure-ref node block closure (incf n) (cdr loc)))))
1126           (vop setup-environment node block start-label)))
1127
1128     (unless (eq (functional-kind fun) :toplevel)
1129       (let ((vars (lambda-vars fun))
1130             (n 0))
1131         (when (leaf-refs (first vars))
1132           (emit-move node block (make-arg-count-location)
1133                      (leaf-info (first vars))))
1134         (dolist (arg (rest vars))
1135           (when (leaf-refs arg)
1136             (let ((pass (standard-arg-location n))
1137                   (home (leaf-info arg)))
1138               (if (lambda-var-indirect arg)
1139                   (emit-make-value-cell node block pass home)
1140                   (emit-move node block pass home))))
1141           (incf n))))
1142
1143     (emit-move node block (make-old-fp-passing-location t)
1144                (ir2-physenv-old-fp env)))
1145
1146   (values))
1147
1148 ;;; Emit function prolog code. This is only called on bind nodes for
1149 ;;; functions that allocate environments. All semantics of let calls
1150 ;;; are handled by IR2-CONVERT-LET.
1151 ;;;
1152 ;;; If not an XEP, all we do is move the return PC from its passing
1153 ;;; location, since in a local call, the caller allocates the frame
1154 ;;; and sets up the arguments.
1155 (defun ir2-convert-bind (node block)
1156   (declare (type bind node) (type ir2-block block))
1157   (let* ((fun (bind-lambda node))
1158          (env (physenv-info (lambda-physenv fun))))
1159     (aver (member (functional-kind fun)
1160                   '(nil :external :optional :toplevel :cleanup)))
1161
1162     (when (xep-p fun)
1163       (init-xep-environment node block fun)
1164       #!+sb-dyncount
1165       (when *collect-dynamic-statistics*
1166         (vop count-me node block *dynamic-counts-tn*
1167              (block-number (ir2-block-block block)))))
1168
1169     (emit-move node
1170                block
1171                (ir2-physenv-return-pc-pass env)
1172                (ir2-physenv-return-pc env))
1173
1174     #!+unwind-to-frame-and-call-vop
1175     (when (and (lambda-allow-instrumenting fun)
1176                (not (lambda-inline-expanded fun))
1177                (lambda-return fun)
1178                (policy fun (>= insert-debug-catch 2)))
1179       (vop sb!vm::bind-sentinel node block))
1180
1181     (let ((lab (gen-label)))
1182       (setf (ir2-physenv-environment-start env) lab)
1183       (vop note-environment-start node block lab)))
1184
1185   (values))
1186 \f
1187 ;;;; function return
1188
1189 ;;; Do stuff to return from a function with the specified values and
1190 ;;; convention. If the return convention is :FIXED and we aren't
1191 ;;; returning from an XEP, then we do a known return (letting
1192 ;;; representation selection insert the correct move-arg VOPs.)
1193 ;;; Otherwise, we use the unknown-values convention. If there is a
1194 ;;; fixed number of return values, then use RETURN, otherwise use
1195 ;;; RETURN-MULTIPLE.
1196 (defun ir2-convert-return (node block)
1197   (declare (type creturn node) (type ir2-block block))
1198   (let* ((lvar (return-result node))
1199          (2lvar (lvar-info lvar))
1200          (lvar-kind (ir2-lvar-kind 2lvar))
1201          (fun (return-lambda node))
1202          (env (physenv-info (lambda-physenv fun)))
1203          (old-fp (ir2-physenv-old-fp env))
1204          (return-pc (ir2-physenv-return-pc env))
1205          (returns (tail-set-info (lambda-tail-set fun))))
1206     #!+unwind-to-frame-and-call-vop
1207     (when (and (lambda-allow-instrumenting fun)
1208                (not (lambda-inline-expanded fun))
1209                (policy fun (>= insert-debug-catch 2)))
1210       (vop sb!vm::unbind-sentinel node block))
1211     (cond
1212      ((and (eq (return-info-kind returns) :fixed)
1213            (not (xep-p fun)))
1214       (let ((locs (lvar-tns node block lvar
1215                                     (return-info-types returns))))
1216         (vop* known-return node block
1217               (old-fp return-pc (reference-tn-list locs nil))
1218               (nil)
1219               (return-info-locations returns))))
1220      ((eq lvar-kind :fixed)
1221       (let* ((types (mapcar #'tn-primitive-type (ir2-lvar-locs 2lvar)))
1222              (lvar-locs (lvar-tns node block lvar types))
1223              (nvals (length lvar-locs))
1224              (locs (make-standard-value-tns nvals)))
1225         (mapc (lambda (val loc)
1226                 (emit-move node block val loc))
1227               lvar-locs
1228               locs)
1229         (if (= nvals 1)
1230             (vop return-single node block old-fp return-pc (car locs))
1231             (vop* return node block
1232                   (old-fp return-pc (reference-tn-list locs nil))
1233                   (nil)
1234                   nvals))))
1235      (t
1236       (aver (eq lvar-kind :unknown))
1237       (vop* return-multiple node block
1238             (old-fp return-pc
1239                     (reference-tn-list (ir2-lvar-locs 2lvar) nil))
1240             (nil)))))
1241
1242   (values))
1243 \f
1244 ;;;; debugger hooks
1245
1246 ;;; This is used by the debugger to find the top function on the
1247 ;;; stack. It returns the OLD-FP and RETURN-PC for the current
1248 ;;; function as multiple values.
1249 (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
1250   (let ((ir2-physenv (physenv-info (node-physenv node))))
1251     (move-lvar-result node block
1252                       (list (ir2-physenv-old-fp ir2-physenv)
1253                             (ir2-physenv-return-pc ir2-physenv))
1254                       (node-lvar node))))
1255 \f
1256 ;;;; multiple values
1257
1258 ;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates
1259 ;;; the lvar for the correct number of values (with the lvar user
1260 ;;; responsible for defaulting), we can just pick them up from the
1261 ;;; lvar.
1262 (defun ir2-convert-mv-bind (node block)
1263   (declare (type mv-combination node) (type ir2-block block))
1264   (let* ((lvar (first (basic-combination-args node)))
1265          (fun (ref-leaf (lvar-uses (basic-combination-fun node))))
1266          (vars (lambda-vars fun)))
1267     (aver (eq (functional-kind fun) :mv-let))
1268     (mapc (lambda (src var)
1269             (when (leaf-refs var)
1270               (let ((dest (leaf-info var)))
1271                 (if (lambda-var-indirect var)
1272                     (emit-make-value-cell node block src dest)
1273                     (emit-move node block src dest)))))
1274           (lvar-tns node block lvar
1275                             (mapcar (lambda (x)
1276                                       (primitive-type (leaf-type x)))
1277                                     vars))
1278           vars))
1279   (values))
1280
1281 ;;; Emit the appropriate fixed value, unknown value or tail variant of
1282 ;;; CALL-VARIABLE. Note that we only need to pass the values start for
1283 ;;; the first argument: all the other argument lvar TNs are
1284 ;;; ignored. This is because we require all of the values globs to be
1285 ;;; contiguous and on stack top.
1286 (defun ir2-convert-mv-call (node block)
1287   (declare (type mv-combination node) (type ir2-block block))
1288   (aver (basic-combination-args node))
1289   (let* ((start-lvar (lvar-info (first (basic-combination-args node))))
1290          (start (first (ir2-lvar-locs start-lvar)))
1291          (tails (and (node-tail-p node)
1292                      (lambda-tail-set (node-home-lambda node))))
1293          (lvar (node-lvar node))
1294          (2lvar (and lvar (lvar-info lvar))))
1295     (multiple-value-bind (fun named)
1296         (fun-lvar-tn node block (basic-combination-fun node))
1297       (aver (and (not named)
1298                  (eq (ir2-lvar-kind start-lvar) :unknown)))
1299       (cond
1300        (tails
1301         (let ((env (physenv-info (node-physenv node))))
1302           (vop tail-call-variable node block start fun
1303                (ir2-physenv-old-fp env)
1304                (ir2-physenv-return-pc env))))
1305        ((and 2lvar
1306              (eq (ir2-lvar-kind 2lvar) :unknown))
1307         (vop* multiple-call-variable node block (start fun nil)
1308               ((reference-tn-list (ir2-lvar-locs 2lvar) t))
1309               (emit-step-p node)))
1310        (t
1311         (let ((locs (standard-result-tns lvar)))
1312           (vop* call-variable node block (start fun nil)
1313                 ((reference-tn-list locs t)) (length locs)
1314                 (emit-step-p node))
1315           (move-lvar-result node block locs lvar)))))))
1316
1317 ;;; Reset the stack pointer to the start of the specified
1318 ;;; unknown-values lvar (discarding it and all values globs on top of
1319 ;;; it.)
1320 (defoptimizer (%pop-values ir2-convert) ((%lvar) node block)
1321   (let* ((lvar (lvar-value %lvar))
1322          (2lvar (lvar-info lvar)))
1323     (cond ((eq (ir2-lvar-kind 2lvar) :unknown)
1324            (vop reset-stack-pointer node block
1325                 (first (ir2-lvar-locs 2lvar))))
1326           ((lvar-dynamic-extent lvar)
1327            (vop reset-stack-pointer node block
1328                 (ir2-lvar-stack-pointer 2lvar)))
1329           (t (bug "Trying to pop a not stack-allocated LVAR ~S."
1330                   lvar)))))
1331
1332 (defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved
1333                                                       &rest moved)
1334                                          node block)
1335   (let* ( ;; pointer immediately after the nipped block
1336          (after (lvar-value last-nipped))
1337          (2after (lvar-info after))
1338          ;; pointer to the first nipped word
1339          (first (lvar-value last-preserved))
1340          (2first (lvar-info first))
1341
1342          (moved-tns (loop for lvar-ref in moved
1343                           for lvar = (lvar-value lvar-ref)
1344                           for 2lvar = (lvar-info lvar)
1345                                         ;when 2lvar
1346                           collect (first (ir2-lvar-locs 2lvar)))))
1347     (aver (or (eq (ir2-lvar-kind 2after) :unknown)
1348               (lvar-dynamic-extent after)))
1349     (aver (eq (ir2-lvar-kind 2first) :unknown))
1350     (when *check-consistency*
1351       ;; we cannot move stack-allocated DX objects
1352       (dolist (moved-lvar moved)
1353         (aver (eq (ir2-lvar-kind (lvar-info (lvar-value moved-lvar)))
1354                   :unknown))))
1355     (flet ((nip-aligned (nipped)
1356              (vop* %%nip-values node block
1357                    (nipped
1358                     (first (ir2-lvar-locs 2first))
1359                     (reference-tn-list moved-tns nil))
1360                    ((reference-tn-list moved-tns t)))))
1361       (cond ((eq (ir2-lvar-kind 2after) :unknown)
1362              (nip-aligned (first (ir2-lvar-locs 2after))))
1363             ((lvar-dynamic-extent after)
1364              (nip-aligned (ir2-lvar-stack-pointer 2after)))
1365             (t
1366              (bug "Trying to nip a not stack-allocated LVAR ~S." after))))))
1367
1368 ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT.
1369 (defoptimizer (values ir2-convert) ((&rest values) node block)
1370   (let ((tns (mapcar (lambda (x)
1371                        (lvar-tn node block x))
1372                      values)))
1373     (move-lvar-result node block tns (node-lvar node))))
1374
1375 ;;; In the normal case where unknown values are desired, we use the
1376 ;;; VALUES-LIST VOP. In the relatively unimportant case of VALUES-LIST
1377 ;;; for a fixed number of values, we punt by doing a full call to the
1378 ;;; VALUES-LIST function. This gets the full call VOP to deal with
1379 ;;; defaulting any unsupplied values. It seems unworthwhile to
1380 ;;; optimize this case.
1381 (defoptimizer (values-list ir2-convert) ((list) node block)
1382   (let* ((lvar (node-lvar node))
1383          (2lvar (and lvar (lvar-info lvar))))
1384     (cond ((and 2lvar
1385                 (eq (ir2-lvar-kind 2lvar) :unknown))
1386            (let ((locs (ir2-lvar-locs 2lvar)))
1387              (vop* values-list node block
1388                    ((lvar-tn node block list) nil)
1389                    ((reference-tn-list locs t)))))
1390           (t (aver (or (not 2lvar) ; i.e. we want to check the argument
1391                        (eq (ir2-lvar-kind 2lvar) :fixed)))
1392              (ir2-convert-full-call node block)))))
1393
1394 (defoptimizer (%more-arg-values ir2-convert) ((context start count) node block)
1395   (binding* ((lvar (node-lvar node) :exit-if-null)
1396              (2lvar (lvar-info lvar)))
1397     (ecase (ir2-lvar-kind 2lvar)
1398       (:fixed (ir2-convert-full-call node block))
1399       (:unknown
1400        (let ((locs (ir2-lvar-locs 2lvar)))
1401          (vop* %more-arg-values node block
1402                ((lvar-tn node block context)
1403                 (lvar-tn node block start)
1404                 (lvar-tn node block count)
1405                 nil)
1406                ((reference-tn-list locs t))))))))
1407 \f
1408 ;;;; special binding
1409
1410 ;;; This is trivial, given our assumption of a shallow-binding
1411 ;;; implementation.
1412 (defoptimizer (%special-bind ir2-convert) ((var value) node block)
1413   (let ((name (leaf-source-name (lvar-value var))))
1414     (vop bind node block (lvar-tn node block value)
1415          (emit-constant name))))
1416 (defoptimizer (%special-unbind ir2-convert) ((var) node block)
1417   (vop unbind node block))
1418
1419 ;;; ### It's not clear that this really belongs in this file, or
1420 ;;; should really be done this way, but this is the least violation of
1421 ;;; abstraction in the current setup. We don't want to wire
1422 ;;; shallow-binding assumptions into IR1tran.
1423 (def-ir1-translator progv
1424     ((vars vals &body body) start next result)
1425   (ir1-convert
1426    start next result
1427    (with-unique-names (bind unbind)
1428      (once-only ((n-save-bs '(%primitive current-binding-pointer)))
1429        `(unwind-protect
1430              (progn
1431                (labels ((,unbind (vars)
1432                           (declare (optimize (speed 2) (debug 0)))
1433                           (let ((unbound-marker (%primitive make-other-immediate-type
1434                                                             0 sb!vm:unbound-marker-widetag)))
1435                             (dolist (var vars)
1436                               ;; CLHS says "bound and then made to have no value" -- user
1437                               ;; should not be able to tell the difference between that and this.
1438                               (about-to-modify-symbol-value var "bind ~S")
1439                               (%primitive bind unbound-marker var))))
1440                         (,bind (vars vals)
1441                           (declare (optimize (speed 2) (debug 0)))
1442                           (cond ((null vars))
1443                                 ((null vals) (,unbind vars))
1444                                 (t
1445                                  (let ((val (car vals))
1446                                        (var (car vars)))
1447                                    (about-to-modify-symbol-value var "bind ~S" val)
1448                                    (%primitive bind val var))
1449                                  (,bind (cdr vars) (cdr vals))))))
1450                  (,bind ,vars ,vals))
1451                nil
1452                ,@body)
1453           ;; Technically ANSI CL doesn't allow declarations at the
1454           ;; start of the cleanup form. SBCL happens to allow for
1455           ;; them, due to the way the UNWIND-PROTECT ir1 translation
1456           ;; is implemented; the cleanup forms are directly spliced
1457           ;; into an FLET definition body. And a declaration here
1458           ;; actually has exactly the right scope for what we need
1459           ;; (ensure that debug instrumentation is not emitted for the
1460           ;; cleanup function). -- JES, 2007-06-16
1461           (declare (optimize (insert-debug-catch 0)))
1462           (%primitive unbind-to-here ,n-save-bs))))))
1463 \f
1464 ;;;; non-local exit
1465
1466 ;;; Convert a non-local lexical exit. First find the NLX-INFO in our
1467 ;;; environment. Note that this is never called on the escape exits
1468 ;;; for CATCH and UNWIND-PROTECT, since the escape functions aren't
1469 ;;; IR2 converted.
1470 (defun ir2-convert-exit (node block)
1471   (declare (type exit node) (type ir2-block block))
1472   (let* ((nlx (exit-nlx-info node))
1473          (loc (find-in-physenv nlx (node-physenv node)))
1474          (temp (make-stack-pointer-tn))
1475          (value (exit-value node)))
1476     (if (nlx-info-safe-p nlx)
1477         (vop value-cell-ref node block loc temp)
1478         (emit-move node block loc temp))
1479     (if value
1480         (let ((locs (ir2-lvar-locs (lvar-info value))))
1481           (vop unwind node block temp (first locs) (second locs)))
1482         (let ((0-tn (emit-constant 0)))
1483           (vop unwind node block temp 0-tn 0-tn))))
1484
1485   (values))
1486
1487 ;;; %CLEANUP-POINT doesn't do anything except prevent the body from
1488 ;;; being entirely deleted.
1489 (defoptimizer (%cleanup-point ir2-convert) (() node block) node block)
1490
1491 ;;; This function invalidates a lexical exit on exiting from the
1492 ;;; dynamic extent. This is done by storing 0 into the indirect value
1493 ;;; cell that holds the closed unwind block.
1494 (defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
1495   (let ((nlx (lvar-value info)))
1496     (when (nlx-info-safe-p nlx)
1497       (vop value-cell-set node block
1498            (find-in-physenv nlx (node-physenv node))
1499            (emit-constant 0)))))
1500
1501 ;;; We have to do a spurious move of no values to the result lvar so
1502 ;;; that lifetime analysis won't get confused.
1503 (defun ir2-convert-throw (node block)
1504   (declare (type mv-combination node) (type ir2-block block))
1505   (let ((args (basic-combination-args node)))
1506     (check-catch-tag-type (first args))
1507     (vop* throw node block
1508           ((lvar-tn node block (first args))
1509            (reference-tn-list
1510             (ir2-lvar-locs (lvar-info (second args)))
1511             nil))
1512           (nil)))
1513   (move-lvar-result node block () (node-lvar node))
1514   (values))
1515
1516 ;;; Emit code to set up a non-local exit. INFO is the NLX-INFO for the
1517 ;;; exit, and TAG is the lvar for the catch tag (if any.) We get at
1518 ;;; the target PC by passing in the label to the vop. The vop is
1519 ;;; responsible for building a return-PC object.
1520 (defun emit-nlx-start (node block info tag)
1521   (declare (type node node) (type ir2-block block) (type nlx-info info)
1522            (type (or lvar null) tag))
1523   (let* ((2info (nlx-info-info info))
1524          (kind (cleanup-kind (nlx-info-cleanup info)))
1525          (block-tn (physenv-live-tn
1526                     (make-normal-tn (primitive-type-or-lose 'catch-block))
1527                     (node-physenv node)))
1528          (res (make-stack-pointer-tn))
1529          (target-label (ir2-nlx-info-target 2info)))
1530
1531     (vop current-binding-pointer node block
1532          (car (ir2-nlx-info-dynamic-state 2info)))
1533     (vop* save-dynamic-state node block
1534           (nil)
1535           ((reference-tn-list (cdr (ir2-nlx-info-dynamic-state 2info)) t)))
1536     (vop current-stack-pointer node block (ir2-nlx-info-save-sp 2info))
1537
1538     (ecase kind
1539       (:catch
1540        (vop make-catch-block node block block-tn
1541             (lvar-tn node block tag) target-label res))
1542       ((:unwind-protect :block :tagbody)
1543        (vop make-unwind-block node block block-tn target-label res)))
1544
1545     (ecase kind
1546       ((:block :tagbody)
1547        (if (nlx-info-safe-p info)
1548            (emit-make-value-cell node block res (ir2-nlx-info-home 2info))
1549            (emit-move node block res (ir2-nlx-info-home 2info))))
1550       (:unwind-protect
1551        (vop set-unwind-protect node block block-tn))
1552       (:catch)))
1553
1554   (values))
1555
1556 ;;; Scan each of ENTRY's exits, setting up the exit for each lexical exit.
1557 (defun ir2-convert-entry (node block)
1558   (declare (type entry node) (type ir2-block block))
1559   (let ((nlxes '()))
1560     (dolist (exit (entry-exits node))
1561       (let ((info (exit-nlx-info exit)))
1562         (when (and info
1563                    (not (memq info nlxes))
1564                    (member (cleanup-kind (nlx-info-cleanup info))
1565                            '(:block :tagbody)))
1566           (push info nlxes)
1567           (emit-nlx-start node block info nil)))))
1568   (values))
1569
1570 ;;; Set up the unwind block for these guys.
1571 (defoptimizer (%catch ir2-convert) ((info-lvar tag) node block)
1572   (check-catch-tag-type tag)
1573   (emit-nlx-start node block (lvar-value info-lvar) tag))
1574 (defoptimizer (%unwind-protect ir2-convert) ((info-lvar cleanup) node block)
1575   (emit-nlx-start node block (lvar-value info-lvar) nil))
1576
1577 ;;; Emit the entry code for a non-local exit. We receive values and
1578 ;;; restore dynamic state.
1579 ;;;
1580 ;;; In the case of a lexical exit or CATCH, we look at the exit lvar's
1581 ;;; kind to determine which flavor of entry VOP to emit. If unknown
1582 ;;; values, emit the xxx-MULTIPLE variant to the lvar locs. If fixed
1583 ;;; values, make the appropriate number of temps in the standard
1584 ;;; values locations and use the other variant, delivering the temps
1585 ;;; to the lvar using MOVE-LVAR-RESULT.
1586 ;;;
1587 ;;; In the UNWIND-PROTECT case, we deliver the first register
1588 ;;; argument, the argument count and the argument pointer to our lvar
1589 ;;; as multiple values. These values are the block exited to and the
1590 ;;; values start and count.
1591 ;;;
1592 ;;; After receiving values, we restore dynamic state. Except in the
1593 ;;; UNWIND-PROTECT case, the values receiving restores the stack
1594 ;;; pointer. In an UNWIND-PROTECT cleanup, we want to leave the stack
1595 ;;; pointer alone, since the thrown values are still out there.
1596 (defoptimizer (%nlx-entry ir2-convert) ((info-lvar) node block)
1597   (let* ((info (lvar-value info-lvar))
1598          (lvar (node-lvar node))
1599          (2info (nlx-info-info info))
1600          (top-loc (ir2-nlx-info-save-sp 2info))
1601          (start-loc (make-nlx-entry-arg-start-location))
1602          (count-loc (make-arg-count-location))
1603          (target (ir2-nlx-info-target 2info)))
1604
1605     (ecase (cleanup-kind (nlx-info-cleanup info))
1606       ((:catch :block :tagbody)
1607        (let ((2lvar (and lvar (lvar-info lvar))))
1608          (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown))
1609              (vop* nlx-entry-multiple node block
1610                    (top-loc start-loc count-loc nil)
1611                    ((reference-tn-list (ir2-lvar-locs 2lvar) t))
1612                    target)
1613              (let ((locs (standard-result-tns lvar)))
1614                (vop* nlx-entry node block
1615                      (top-loc start-loc count-loc nil)
1616                      ((reference-tn-list locs t))
1617                      target
1618                      (length locs))
1619                (move-lvar-result node block locs lvar)))))
1620       (:unwind-protect
1621        (let ((block-loc (standard-arg-location 0)))
1622          (vop uwp-entry node block target block-loc start-loc count-loc)
1623          (move-lvar-result
1624           node block
1625           (list block-loc start-loc count-loc)
1626           lvar))))
1627
1628     #!+sb-dyncount
1629     (when *collect-dynamic-statistics*
1630       (vop count-me node block *dynamic-counts-tn*
1631            (block-number (ir2-block-block block))))
1632
1633     (vop* restore-dynamic-state node block
1634           ((reference-tn-list (cdr (ir2-nlx-info-dynamic-state 2info)) nil))
1635           (nil))
1636     (vop unbind-to-here node block
1637          (car (ir2-nlx-info-dynamic-state 2info)))))
1638 \f
1639 ;;;; n-argument functions
1640
1641 (macrolet ((def (name)
1642              `(defoptimizer (,name ir2-convert) ((&rest args) node block)
1643                 (let* ((refs (move-tail-full-call-args node block))
1644                        (lvar (node-lvar node))
1645                        (res (lvar-result-tns
1646                              lvar
1647                              (list (primitive-type (specifier-type 'list))))))
1648                   (when (and lvar (lvar-dynamic-extent lvar))
1649                     (vop current-stack-pointer node block
1650                          (ir2-lvar-stack-pointer (lvar-info lvar))))
1651                   (vop* ,name node block (refs) ((first res) nil)
1652                         (length args))
1653                   (move-lvar-result node block res lvar)))))
1654   (def list)
1655   (def list*))
1656
1657 \f
1658 ;;; Convert the code in a component into VOPs.
1659 (defun ir2-convert (component)
1660   (declare (type component component))
1661   (let (#!+sb-dyncount
1662         (*dynamic-counts-tn*
1663          (when *collect-dynamic-statistics*
1664            (let* ((blocks
1665                    (block-number (block-next (component-head component))))
1666                   (counts (make-array blocks
1667                                       :element-type '(unsigned-byte 32)
1668                                       :initial-element 0))
1669                   (info (make-dyncount-info
1670                          :for (component-name component)
1671                          :costs (make-array blocks
1672                                             :element-type '(unsigned-byte 32)
1673                                             :initial-element 0)
1674                          :counts counts)))
1675              (setf (ir2-component-dyncount-info (component-info component))
1676                    info)
1677              (emit-constant info)
1678              (emit-constant counts)))))
1679     (let ((num 0))
1680       (declare (type index num))
1681       (do-ir2-blocks (2block component)
1682         (let ((block (ir2-block-block 2block)))
1683           (when (block-start block)
1684             (setf (block-number block) num)
1685             #!+sb-dyncount
1686             (when *collect-dynamic-statistics*
1687               (let ((first-node (block-start-node block)))
1688                 (unless (or (and (bind-p first-node)
1689                                  (xep-p (bind-lambda first-node)))
1690                             (eq (lvar-fun-name
1691                                  (node-lvar first-node))
1692                                 '%nlx-entry))
1693                   (vop count-me
1694                        first-node
1695                        2block
1696                        #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil
1697                        num))))
1698             (ir2-convert-block block)
1699             (incf num))))))
1700   (values))
1701
1702 ;;; If necessary, emit a terminal unconditional branch to go to the
1703 ;;; successor block. If the successor is the component tail, then
1704 ;;; there isn't really any successor, but if the end is an unknown,
1705 ;;; non-tail call, then we emit an error trap just in case the
1706 ;;; function really does return.
1707 (defun finish-ir2-block (block)
1708   (declare (type cblock block))
1709   (let* ((2block (block-info block))
1710          (last (block-last block))
1711          (succ (block-succ block)))
1712     (unless (if-p last)
1713       (aver (singleton-p succ))
1714       (let ((target (first succ)))
1715         (cond ((eq target (component-tail (block-component block)))
1716                (when (and (basic-combination-p last)
1717                           (eq (basic-combination-kind last) :full))
1718                  (let* ((fun (basic-combination-fun last))
1719                         (use (lvar-uses fun))
1720                         (name (and (ref-p use)
1721                                    (leaf-has-source-name-p (ref-leaf use))
1722                                    (leaf-source-name (ref-leaf use)))))
1723                    (unless (or (node-tail-p last)
1724                                (info :function :info name)
1725                                (policy last (zerop safety)))
1726                      (vop nil-fun-returned-error last 2block
1727                           (if name
1728                               (emit-constant name)
1729                               (multiple-value-bind (tn named)
1730                                   (fun-lvar-tn last 2block fun)
1731                                 (aver (not named))
1732                                 tn)))))))
1733               ((not (eq (ir2-block-next 2block) (block-info target)))
1734                (vop branch last 2block (block-label target)))))))
1735
1736   (values))
1737
1738 ;;; Convert the code in a block into VOPs.
1739 (defun ir2-convert-block (block)
1740   (declare (type cblock block))
1741   (let ((2block (block-info block)))
1742     (do-nodes (node lvar block)
1743       (etypecase node
1744         (ref
1745          (when lvar
1746            (let ((2lvar (lvar-info lvar)))
1747              ;; function REF in a local call is not annotated
1748              (when (and 2lvar (not (eq (ir2-lvar-kind 2lvar) :delayed)))
1749                (ir2-convert-ref node 2block)))))
1750         (combination
1751          (let ((kind (basic-combination-kind node)))
1752            (ecase kind
1753              (:local
1754               (ir2-convert-local-call node 2block))
1755              (:full
1756               (ir2-convert-full-call node 2block))
1757              (:known
1758               (let* ((info (basic-combination-fun-info node))
1759                      (fun (fun-info-ir2-convert info)))
1760                 (cond (fun
1761                        (funcall fun node 2block))
1762                       ((eq (basic-combination-info node) :full)
1763                        (ir2-convert-full-call node 2block))
1764                       (t
1765                        (ir2-convert-template node 2block))))))))
1766         (cif
1767          (when (lvar-info (if-test node))
1768            (ir2-convert-if node 2block)))
1769         (bind
1770          (let ((fun (bind-lambda node)))
1771            (when (eq (lambda-home fun) fun)
1772              (ir2-convert-bind node 2block))))
1773         (creturn
1774          (ir2-convert-return node 2block))
1775         (cset
1776          (ir2-convert-set node 2block))
1777         (cast
1778          (ir2-convert-cast node 2block))
1779         (mv-combination
1780          (cond
1781            ((eq (basic-combination-kind node) :local)
1782             (ir2-convert-mv-bind node 2block))
1783            ((eq (lvar-fun-name (basic-combination-fun node))
1784                 '%throw)
1785             (ir2-convert-throw node 2block))
1786            (t
1787             (ir2-convert-mv-call node 2block))))
1788         (exit
1789          (when (exit-entry node)
1790            (ir2-convert-exit node 2block)))
1791         (entry
1792          (ir2-convert-entry node 2block)))))
1793
1794   (finish-ir2-block block)
1795
1796   (values))