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