src/compiler/x86-64/call.lisp

   1 ;;;; function call for the x86 VM
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13 \f
  14 ;;;; interfaces to IR2 conversion
  15
  16 ;;; Return a wired TN describing the N'th full call argument passing
  17 ;;; location.
  18 (!def-vm-support-routine standard-arg-location (n)
  19   (declare (type unsigned-byte n))
  20   (if (< n register-arg-count)
  21       (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number
  22                      (nth n *register-arg-offsets*))
  23       (make-wired-tn *backend-t-primitive-type* control-stack-sc-number n)))
  24
  25 ;;; Make a passing location TN for a local call return PC.
  26 ;;;
  27 ;;; Always wire the return PC location to the stack in its standard
  28 ;;; location.
  29 (!def-vm-support-routine make-return-pc-passing-location (standard)
  30   (declare (ignore standard))
  31   (make-wired-tn (primitive-type-or-lose 'system-area-pointer)
  32                  sap-stack-sc-number return-pc-save-offset))
  33
  34 ;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a
  35 ;;; location to pass OLD-FP in.
  36 ;;;
  37 ;;; This is wired in both the standard and the local-call conventions,
  38 ;;; because we want to be able to assume it's always there. Besides,
  39 ;;; the x86 doesn't have enough registers to really make it profitable
  40 ;;; to pass it in a register.
  41 (!def-vm-support-routine make-old-fp-passing-location (standard)
  42   (declare (ignore standard))
  43   (make-wired-tn *fixnum-primitive-type* control-stack-sc-number
  44                  ocfp-save-offset))
  45
  46 ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current
  47 ;;; function. We treat these specially so that the debugger can find
  48 ;;; them at a known location.
  49 ;;;
  50 ;;; Without using a save-tn - which does not make much sense if it is
  51 ;;; wired to the stack?
  52 (!def-vm-support-routine make-old-fp-save-location (physenv)
  53   (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type*
  54                                         control-stack-sc-number
  55                                         ocfp-save-offset)
  56                          physenv))
  57 (!def-vm-support-routine make-return-pc-save-location (physenv)
  58   (physenv-debug-live-tn
  59    (make-wired-tn (primitive-type-or-lose 'system-area-pointer)
  60                   sap-stack-sc-number return-pc-save-offset)
  61    physenv))
  62
  63 ;;; Make a TN for the standard argument count passing location. We only
  64 ;;; need to make the standard location, since a count is never passed when we
  65 ;;; are using non-standard conventions.
  66 (!def-vm-support-routine make-arg-count-location ()
  67   (make-wired-tn *fixnum-primitive-type* any-reg-sc-number rcx-offset))
  68
  69 ;;; Make a TN to hold the number-stack frame pointer. This is allocated
  70 ;;; once per component, and is component-live.
  71 (!def-vm-support-routine make-nfp-tn ()
  72   (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
  73
  74 (!def-vm-support-routine make-stack-pointer-tn ()
  75   (make-normal-tn *fixnum-primitive-type*))
  76
  77 (!def-vm-support-routine make-number-stack-pointer-tn ()
  78   (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
  79
  80 ;;; Return a list of TNs that can be used to represent an unknown-values
  81 ;;; continuation within a function.
  82 (!def-vm-support-routine make-unknown-values-locations ()
  83   (list (make-stack-pointer-tn)
  84         (make-normal-tn *fixnum-primitive-type*)))
  85
  86 ;;; This function is called by the ENTRY-ANALYZE phase, allowing
  87 ;;; VM-dependent initialization of the IR2-COMPONENT structure. We
  88 ;;; push placeholder entries in the CONSTANTS to leave room for
  89 ;;; additional noise in the code object header.
  90 (!def-vm-support-routine select-component-format (component)
  91   (declare (type component component))
  92   ;; The 1+ here is because for the x86 the first constant is a
  93   ;; pointer to a list of fixups, or NIL if the code object has none.
  94   ;; (If I understand correctly, the fixups are needed at GC copy
  95   ;; time because the X86 code isn't relocatable.)
  96   ;;
  97   ;; KLUDGE: It'd be cleaner to have the fixups entry be a named
  98   ;; element of the CODE (aka component) primitive object. However,
  99   ;; it's currently a large, tricky, error-prone chore to change
 100   ;; the layout of any primitive object, so for the foreseeable future
 101   ;; we'll just live with this ugliness. -- WHN 2002-01-02
 102   (dotimes (i (1+ code-constants-offset))
 103     (vector-push-extend nil
 104                         (ir2-component-constants (component-info component))))
 105   (values))
 106 \f
 107 ;;;; frame hackery
 108
 109 ;;; This is used for setting up the Old-FP in local call.
 110 (define-vop (current-fp)
 111   (:results (val :scs (any-reg control-stack)))
 112   (:generator 1
 113     (move val rbp-tn)))
 114
 115 ;;; We don't have a separate NFP, so we don't need to do anything here.
 116 (define-vop (compute-old-nfp)
 117   (:results (val))
 118   (:ignore val)
 119   (:generator 1
 120     nil))
 121
 122 (define-vop (xep-allocate-frame)
 123   (:info start-lab copy-more-arg-follows)
 124   (:vop-var vop)
 125   (:generator 1
 126     (align n-lowtag-bits)
 127     (trace-table-entry trace-table-fun-prologue)
 128     (emit-label start-lab)
 129     ;; Skip space for the function header.
 130     (inst simple-fun-header-word)
 131     (dotimes (i (* n-word-bytes (1- simple-fun-code-offset)))
 132       (inst byte 0))
 133
 134     ;; The start of the actual code.
 135     ;; Save the return-pc.
 136     (popw rbp-tn (- (1+ return-pc-save-offset)))
 137
 138     ;; If copy-more-arg follows it will allocate the correct stack
 139     ;; size. The stack is not allocated first here as this may expose
 140     ;; args on the stack if they take up more space than the frame!
 141     (unless copy-more-arg-follows
 142       ;; The args fit within the frame so just allocate the frame.
 143       (inst lea rsp-tn
 144             (make-ea :qword :base rbp-tn
 145                      :disp (- (* n-word-bytes
 146                                  (max 3 (sb-allocated-size 'stack)))))))
 147
 148     (trace-table-entry trace-table-normal)))
 149
 150 ;;; This is emitted directly before either a known-call-local, call-local,
 151 ;;; or a multiple-call-local. All it does is allocate stack space for the
 152 ;;; callee (who has the same size stack as us).
 153 (define-vop (allocate-frame)
 154   (:results (res :scs (any-reg control-stack))
 155             (nfp))
 156   (:info callee)
 157   (:ignore nfp callee)
 158   (:generator 2
 159     (move res rsp-tn)
 160     (inst sub rsp-tn (* n-word-bytes (sb-allocated-size 'stack)))))
 161
 162 ;;; Allocate a partial frame for passing stack arguments in a full
 163 ;;; call. NARGS is the number of arguments passed. We allocate at
 164 ;;; least 3 slots, because the XEP noise is going to want to use them
 165 ;;; before it can extend the stack.
 166 (define-vop (allocate-full-call-frame)
 167   (:info nargs)
 168   (:results (res :scs (any-reg control-stack)))
 169   (:generator 2
 170     (move res rsp-tn)
 171     (inst sub rsp-tn (* (max nargs 3) n-word-bytes))))
 172 \f
 173 ;;; Emit code needed at the return-point from an unknown-values call
 174 ;;; for a fixed number of values. Values is the head of the TN-REF
 175 ;;; list for the locations that the values are to be received into.
 176 ;;; Nvals is the number of values that are to be received (should
 177 ;;; equal the length of Values).
 178 ;;;
 179 ;;; MOVE-TEMP is a DESCRIPTOR-REG TN used as a temporary.
 180 ;;;
 181 ;;; This code exploits the fact that in the unknown-values convention,
 182 ;;; a single value return returns at the return PC + 2, whereas a
 183 ;;; return of other than one value returns directly at the return PC.
 184 ;;;
 185 ;;; If 0 or 1 values are expected, then we just emit an instruction to
 186 ;;; reset the SP (which will only be executed when other than 1 value
 187 ;;; is returned.)
 188 ;;;
 189 ;;; In the general case we have to do three things:
 190 ;;;  -- Default unsupplied register values. This need only be done
 191 ;;;     when a single value is returned, since register values are
 192 ;;;     defaulted by the called in the non-single case.
 193 ;;;  -- Default unsupplied stack values. This needs to be done whenever
 194 ;;;     there are stack values.
 195 ;;;  -- Reset SP. This must be done whenever other than 1 value is
 196 ;;;     returned, regardless of the number of values desired.
 197 (defun default-unknown-values (vop values nvals)
 198   (declare (type (or tn-ref null) values)
 199            (type unsigned-byte nvals))
 200   (cond
 201    ((<= nvals 1)
 202     (note-this-location vop :single-value-return)
 203     (inst mov rsp-tn rbx-tn))
 204    ((<= nvals register-arg-count)
 205     (let ((regs-defaulted (gen-label)))
 206       (note-this-location vop :unknown-return)
 207       (inst jmp-short regs-defaulted)
 208       ;; Default the unsupplied registers.
 209       (let* ((2nd-tn-ref (tn-ref-across values))
 210              (2nd-tn (tn-ref-tn 2nd-tn-ref)))
 211         (inst mov 2nd-tn nil-value)
 212         (when (> nvals 2)
 213           (loop
 214             for tn-ref = (tn-ref-across 2nd-tn-ref)
 215             then (tn-ref-across tn-ref)
 216             for count from 2 below register-arg-count
 217             do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
 218       (inst mov rbx-tn rsp-tn)
 219       (emit-label regs-defaulted)
 220       (inst mov rsp-tn rbx-tn)))
 221    ((<= nvals 7)
 222     ;; The number of bytes depends on the relative jump instructions.
 223     ;; Best case is 31+(n-3)*14, worst case is 35+(n-3)*18. For
 224     ;; NVALS=6 that is 73/89 bytes, and for NVALS=7 that is 87/107
 225     ;; bytes which is likely better than using the blt below.
 226     (let ((regs-defaulted (gen-label))
 227           (defaulting-done (gen-label))
 228           (default-stack-slots (gen-label)))
 229       (note-this-location vop :unknown-return)
 230       ;; Branch off to the MV case.
 231       (inst jmp-short regs-defaulted)
 232       ;; Do the single value case.
 233       ;; Default the register args
 234       (inst mov rax-tn nil-value)
 235       (do ((i 1 (1+ i))
 236            (val (tn-ref-across values) (tn-ref-across val)))
 237           ((= i (min nvals register-arg-count)))
 238         (inst mov (tn-ref-tn val) rax-tn))
 239
 240       ;; Fake other registers so it looks like we returned with all the
 241       ;; registers filled in.
 242       (move rbx-tn rsp-tn)
 243       (inst push rdx-tn)
 244       (inst jmp default-stack-slots)
 245
 246       (emit-label regs-defaulted)
 247
 248       (inst mov rax-tn nil-value)
 249       (storew rdx-tn rbx-tn -1)
 250       (collect ((defaults))
 251         (do ((i register-arg-count (1+ i))
 252              (val (do ((i 0 (1+ i))
 253                        (val values (tn-ref-across val)))
 254                       ((= i register-arg-count) val))
 255                   (tn-ref-across val)))
 256             ((null val))
 257           (let ((default-lab (gen-label))
 258                 (tn (tn-ref-tn val)))
 259             (defaults (cons default-lab tn))
 260
 261             (inst cmp rcx-tn (fixnumize i))
 262             (inst jmp :be default-lab)
 263             (loadw rdx-tn rbx-tn (- (1+ i)))
 264             (inst mov tn rdx-tn)))
 265
 266         (emit-label defaulting-done)
 267         (loadw rdx-tn rbx-tn -1)
 268         (move rsp-tn rbx-tn)
 269
 270         (let ((defaults (defaults)))
 271           (when defaults
 272             (assemble (*elsewhere*)
 273               (trace-table-entry trace-table-fun-prologue)
 274               (emit-label default-stack-slots)
 275               (dolist (default defaults)
 276                 (emit-label (car default))
 277                 (inst mov (cdr default) rax-tn))
 278               (inst jmp defaulting-done)
 279               (trace-table-entry trace-table-normal)))))))
 280    (t
 281     (let ((regs-defaulted (gen-label))
 282           (restore-edi (gen-label))
 283           (no-stack-args (gen-label))
 284           (default-stack-vals (gen-label))
 285           (count-okay (gen-label)))
 286       (note-this-location vop :unknown-return)
 287       ;; Branch off to the MV case.
 288       (inst jmp-short regs-defaulted)
 289
 290       ;; Default the register args, and set up the stack as if we
 291       ;; entered the MV return point.
 292       (inst mov rbx-tn rsp-tn)
 293       (inst push rdx-tn)
 294       (inst mov rdi-tn nil-value)
 295       (inst push rdi-tn)
 296       (inst mov rsi-tn rdi-tn)
 297       ;; Compute a pointer to where to put the [defaulted] stack values.
 298       (emit-label no-stack-args)
 299       (inst lea rdi-tn
 300             (make-ea :qword :base rbp-tn
 301                      :disp (* (- (1+ register-arg-count)) n-word-bytes)))
 302       ;; Load RAX with NIL so we can quickly store it, and set up
 303       ;; stuff for the loop.
 304       (inst mov rax-tn nil-value)
 305       (inst std)
 306       (inst mov rcx-tn (- nvals register-arg-count))
 307       ;; Jump into the default loop.
 308       (inst jmp default-stack-vals)
 309
 310       ;; The regs are defaulted. We need to copy any stack arguments,
 311       ;; and then default the remaining stack arguments.
 312       (emit-label regs-defaulted)
 313       ;; Save EDI.
 314       (storew rdi-tn rbx-tn (- (1+ 1)))
 315       ;; Compute the number of stack arguments, and if it's zero or
 316       ;; less, don't copy any stack arguments.
 317       (inst sub rcx-tn (fixnumize register-arg-count))
 318       (inst jmp :le no-stack-args)
 319
 320       ;; Throw away any unwanted args.
 321       (inst cmp rcx-tn (fixnumize (- nvals register-arg-count)))
 322       (inst jmp :be count-okay)
 323       (inst mov rcx-tn (fixnumize (- nvals register-arg-count)))
 324       (emit-label count-okay)
 325       ;; Save the number of stack values.
 326       (inst mov rax-tn rcx-tn)
 327       ;; Compute a pointer to where the stack args go.
 328       (inst lea rdi-tn
 329             (make-ea :qword :base rbp-tn
 330                      :disp (* (- (1+ register-arg-count)) n-word-bytes)))
 331       ;; Save ESI, and compute a pointer to where the args come from.
 332       (storew rsi-tn rbx-tn (- (1+ 2)))
 333       (inst lea rsi-tn
 334             (make-ea :qword :base rbx-tn
 335                      :disp (* (- (1+ register-arg-count)) n-word-bytes)))
 336       ;; Do the copy.
 337       (inst shr rcx-tn word-shift)              ; make word count
 338       (inst std)
 339       (inst rep)
 340       (inst movs :qword)
 341       ;; Restore RSI.
 342       (loadw rsi-tn rbx-tn (- (1+ 2)))
 343       ;; Now we have to default the remaining args. Find out how many.
 344       (inst sub rax-tn (fixnumize (- nvals register-arg-count)))
 345       (inst neg rax-tn)
 346       ;; If none, then just blow out of here.
 347       (inst jmp :le restore-edi)
 348       (inst mov rcx-tn rax-tn)
 349       (inst shr rcx-tn word-shift)      ; word count
 350       ;; Load RAX with NIL for fast storing.
 351       (inst mov rax-tn nil-value)
 352       ;; Do the store.
 353       (emit-label default-stack-vals)
 354       (inst rep)
 355       (inst stos rax-tn)
 356       ;; Restore EDI, and reset the stack.
 357       (emit-label restore-edi)
 358       (loadw rdi-tn rbx-tn (- (1+ 1)))
 359       (inst mov rsp-tn rbx-tn))))
 360   (values))
 361 \f
 362 ;;;; unknown values receiving
 363
 364 ;;; Emit code needed at the return point for an unknown-values call
 365 ;;; for an arbitrary number of values.
 366 ;;;
 367 ;;; We do the single and non-single cases with no shared code: there
 368 ;;; doesn't seem to be any potential overlap, and receiving a single
 369 ;;; value is more important efficiency-wise.
 370 ;;;
 371 ;;; When there is a single value, we just push it on the stack,
 372 ;;; returning the old SP and 1.
 373 ;;;
 374 ;;; When there is a variable number of values, we move all of the
 375 ;;; argument registers onto the stack, and return ARGS and NARGS.
 376 ;;;
 377 ;;; ARGS and NARGS are TNs wired to the named locations. We must
 378 ;;; explicitly allocate these TNs, since their lifetimes overlap with
 379 ;;; the results start and count. (Also, it's nice to be able to target
 380 ;;; them.)
 381 (defun receive-unknown-values (args nargs start count)
 382   (declare (type tn args nargs start count))
 383   (let ((variable-values (gen-label))
 384         (done (gen-label)))
 385     (inst jmp-short variable-values)
 386
 387     (cond ((location= start (first *register-arg-tns*))
 388            (inst push (first *register-arg-tns*))
 389            (inst lea start (make-ea :qword :base rsp-tn :disp 8)))
 390           (t (inst mov start rsp-tn)
 391              (inst push (first *register-arg-tns*))))
 392     (inst mov count (fixnumize 1))
 393     (inst jmp done)
 394
 395     (emit-label variable-values)
 396     ;; dtc: this writes the registers onto the stack even if they are
 397     ;; not needed, only the number specified in rcx are used and have
 398     ;; stack allocated to them. No harm is done.
 399     (loop
 400       for arg in *register-arg-tns*
 401       for i downfrom -1
 402       do (storew arg args i))
 403     (move start args)
 404     (move count nargs)
 405
 406     (emit-label done))
 407   (values))
 408
 409 ;;; VOP that can be inherited by unknown values receivers. The main thing this
 410 ;;; handles is allocation of the result temporaries.
 411 (define-vop (unknown-values-receiver)
 412   (:temporary (:sc descriptor-reg :offset rbx-offset
 413                    :from :eval :to (:result 0))
 414               values-start)
 415   (:temporary (:sc any-reg :offset rcx-offset
 416                :from :eval :to (:result 1))
 417               nvals)
 418   (:results (start :scs (any-reg control-stack))
 419             (count :scs (any-reg control-stack))))
 420 \f
 421 ;;;; local call with unknown values convention return
 422
 423 ;;; Non-TR local call for a fixed number of values passed according to
 424 ;;; the unknown values convention.
 425 ;;;
 426 ;;; FP is the frame pointer in install before doing the call.
 427 ;;;
 428 ;;; NFP would be the number-stack frame pointer if we had a separate
 429 ;;; number stack.
 430 ;;;
 431 ;;; Args are the argument passing locations, which are specified only
 432 ;;; to terminate their lifetimes in the caller.
 433 ;;;
 434 ;;; VALUES are the return value locations (wired to the standard
 435 ;;; passing locations). NVALS is the number of values received.
 436 ;;;
 437 ;;; Save is the save info, which we can ignore since saving has been
 438 ;;; done.
 439 ;;;
 440 ;;; TARGET is a continuation pointing to the start of the called
 441 ;;; function.
 442 (define-vop (call-local)
 443   (:args (fp)
 444          (nfp)
 445          (args :more t))
 446   (:results (values :more t))
 447   (:save-p t)
 448   (:move-args :local-call)
 449   (:info arg-locs callee target nvals)
 450   (:vop-var vop)
 451   (:ignore nfp arg-locs args #+nil callee)
 452   (:generator 5
 453     (trace-table-entry trace-table-call-site)
 454     (move rbp-tn fp)
 455
 456     (let ((ret-tn (callee-return-pc-tn callee)))
 457       #+nil
 458       (format t "*call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
 459               ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
 460               (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
 461
 462       ;; Is the return-pc on the stack or in a register?
 463       (sc-case ret-tn
 464         ((sap-stack)
 465          #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
 466                        (tn-offset ret-tn))
 467          (storew (make-fixup nil :code-object return)
 468                  rbp-tn (- (1+ (tn-offset ret-tn)))))
 469         ((sap-reg)
 470          (inst lea ret-tn (make-fixup nil :code-object return)))))
 471
 472     (note-this-location vop :call-site)
 473     (inst jmp target)
 474     RETURN
 475     (default-unknown-values vop values nvals)
 476     (trace-table-entry trace-table-normal)))
 477
 478 ;;; Non-TR local call for a variable number of return values passed according
 479 ;;; to the unknown values convention. The results are the start of the values
 480 ;;; glob and the number of values received.
 481 (define-vop (multiple-call-local unknown-values-receiver)
 482   (:args (fp)
 483          (nfp)
 484          (args :more t))
 485   (:save-p t)
 486   (:move-args :local-call)
 487   (:info save callee target)
 488   (:ignore args save nfp #+nil callee)
 489   (:vop-var vop)
 490   (:generator 20
 491     (trace-table-entry trace-table-call-site)
 492     (move rbp-tn fp)
 493
 494     (let ((ret-tn (callee-return-pc-tn callee)))
 495       #+nil
 496       (format t "*multiple-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
 497               ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
 498               (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
 499
 500       ;; Is the return-pc on the stack or in a register?
 501       (sc-case ret-tn
 502         ((sap-stack)
 503          #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
 504                        (tn-offset ret-tn))
 505          ;; Stack
 506          (storew (make-fixup nil :code-object return)
 507                  rbp-tn (- (1+ (tn-offset ret-tn)))))
 508         ((sap-reg)
 509          ;; Register
 510          (inst lea ret-tn (make-fixup nil :code-object return)))))
 511
 512     (note-this-location vop :call-site)
 513     (inst jmp target)
 514     RETURN
 515     (note-this-location vop :unknown-return)
 516     (receive-unknown-values values-start nvals start count)
 517     (trace-table-entry trace-table-normal)))
 518 \f
 519 ;;;; local call with known values return
 520
 521 ;;; Non-TR local call with known return locations. Known-value return
 522 ;;; works just like argument passing in local call.
 523 ;;;
 524 ;;; Note: we can't use normal load-tn allocation for the fixed args,
 525 ;;; since all registers may be tied up by the more operand. Instead,
 526 ;;; we use MAYBE-LOAD-STACK-TN.
 527 (define-vop (known-call-local)
 528   (:args (fp)
 529          (nfp)
 530          (args :more t))
 531   (:results (res :more t))
 532   (:move-args :local-call)
 533   (:save-p t)
 534   (:info save callee target)
 535   (:ignore args res save nfp #+nil callee)
 536   (:vop-var vop)
 537   (:generator 5
 538     (trace-table-entry trace-table-call-site)
 539     (move rbp-tn fp)
 540
 541     (let ((ret-tn (callee-return-pc-tn callee)))
 542
 543       #+nil
 544       (format t "*known-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
 545               ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
 546               (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
 547
 548       ;; Is the return-pc on the stack or in a register?
 549       (sc-case ret-tn
 550         ((sap-stack)
 551          #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
 552                        (tn-offset ret-tn))
 553          ;; Stack
 554          (storew (make-fixup nil :code-object return)
 555                  rbp-tn (- (1+ (tn-offset ret-tn)))))
 556         ((sap-reg)
 557          ;; Register
 558          (inst lea ret-tn (make-fixup nil :code-object return)))))
 559
 560     (note-this-location vop :call-site)
 561     (inst jmp target)
 562     RETURN
 563     (note-this-location vop :known-return)
 564     (trace-table-entry trace-table-normal)))
 565 \f
 566 ;;; Return from known values call. We receive the return locations as
 567 ;;; arguments to terminate their lifetimes in the returning function. We
 568 ;;; restore FP and CSP and jump to the Return-PC.
 569 ;;;
 570 ;;; We can assume we know exactly where old-fp and return-pc are because
 571 ;;; make-old-fp-save-location and make-return-pc-save-location always
 572 ;;; return the same place.
 573 #+nil
 574 (define-vop (known-return)
 575   (:args (old-fp)
 576          (return-pc :scs (any-reg immediate-stack) :target rpc)
 577          (vals :more t))
 578   (:move-args :known-return)
 579   (:info val-locs)
 580   (:temporary (:sc unsigned-reg :from (:argument 1)) rpc)
 581   (:ignore val-locs vals)
 582   (:vop-var vop)
 583   (:generator 6
 584     (trace-table-entry trace-table-fun-epilogue)
 585     ;; Save the return-pc in a register 'cause the frame-pointer is
 586     ;; going away. Note this not in the usual stack location so we
 587     ;; can't use RET
 588     (move rpc return-pc)
 589     ;; Restore the stack.
 590     (move rsp-tn rbp-tn)
 591     ;; Restore the old fp. We know OLD-FP is going to be in its stack
 592     ;; save slot, which is a different frame that than this one,
 593     ;; so we don't have to worry about having just cleared
 594     ;; most of the stack.
 595     (move rbp-tn old-fp)
 596     (inst jmp rpc)
 597     (trace-table-entry trace-table-normal)))
 598 \f
 599 ;;; From Douglas Crosher
 600 ;;; Return from known values call. We receive the return locations as
 601 ;;; arguments to terminate their lifetimes in the returning function. We
 602 ;;; restore FP and CSP and jump to the Return-PC.
 603 ;;;
 604 ;;; The old-fp may be either in a register or on the stack in its
 605 ;;; standard save locations - slot 0.
 606 ;;;
 607 ;;; The return-pc may be in a register or on the stack in any slot.
 608 (define-vop (known-return)
 609   (:args (old-fp)
 610          (return-pc)
 611          (vals :more t))
 612   (:move-args :known-return)
 613   (:info val-locs)
 614   (:ignore val-locs vals)
 615   (:vop-var vop)
 616   (:generator 6
 617     (trace-table-entry trace-table-fun-epilogue)
 618     ;; return-pc may be either in a register or on the stack.
 619     (sc-case return-pc
 620       ((sap-reg)
 621        (sc-case old-fp
 622          ((control-stack)
 623           (cond ((zerop (tn-offset old-fp))
 624                  ;; Zot all of the stack except for the old-fp.
 625                  (inst lea rsp-tn (make-ea :qword :base rbp-tn
 626                                            :disp (- (* (1+ ocfp-save-offset)
 627                                                        n-word-bytes))))
 628                  ;; Restore the old fp from its save location on the stack,
 629                  ;; and zot the stack.
 630                  (inst pop rbp-tn))
 631
 632                 (t
 633                  (cerror "Continue anyway"
 634                          "VOP return-local doesn't work if old-fp (in slot ~
 635                           ~S) is not in slot 0"
 636                          (tn-offset old-fp)))))
 637
 638          ((any-reg descriptor-reg)
 639           ;; Zot all the stack.
 640           (move rsp-tn rbp-tn)
 641           ;; Restore the old-fp.
 642           (move rbp-tn old-fp)))
 643
 644        ;; Return; return-pc is in a register.
 645        (inst jmp return-pc))
 646
 647       ((sap-stack)
 648        (inst lea rsp-tn
 649              (make-ea :qword :base rbp-tn
 650                       :disp (- (* (1+ (tn-offset return-pc)) n-word-bytes))))
 651        (move rbp-tn old-fp)
 652        (inst ret (* (tn-offset return-pc) n-word-bytes))))
 653
 654     (trace-table-entry trace-table-normal)))
 655 \f
 656 ;;;; full call
 657 ;;;
 658 ;;; There is something of a cross-product effect with full calls.
 659 ;;; Different versions are used depending on whether we know the
 660 ;;; number of arguments or the name of the called function, and
 661 ;;; whether we want fixed values, unknown values, or a tail call.
 662 ;;;
 663 ;;; In full call, the arguments are passed creating a partial frame on
 664 ;;; the stack top and storing stack arguments into that frame. On
 665 ;;; entry to the callee, this partial frame is pointed to by FP.
 666
 667 ;;; This macro helps in the definition of full call VOPs by avoiding
 668 ;;; code replication in defining the cross-product VOPs.
 669 ;;;
 670 ;;; NAME is the name of the VOP to define.
 671 ;;;
 672 ;;; NAMED is true if the first argument is an fdefinition object whose
 673 ;;; definition is to be called.
 674 ;;;
 675 ;;; RETURN is either :FIXED, :UNKNOWN or :TAIL:
 676 ;;; -- If :FIXED, then the call is for a fixed number of values, returned in
 677 ;;;    the standard passing locations (passed as result operands).
 678 ;;; -- If :UNKNOWN, then the result values are pushed on the stack, and the
 679 ;;;    result values are specified by the Start and Count as in the
 680 ;;;    unknown-values continuation representation.
 681 ;;; -- If :TAIL, then do a tail-recursive call. No values are returned.
 682 ;;;    The Old-Fp and Return-PC are passed as the second and third arguments.
 683 ;;;
 684 ;;; In non-tail calls, the pointer to the stack arguments is passed as
 685 ;;; the last fixed argument. If Variable is false, then the passing
 686 ;;; locations are passed as a more arg. Variable is true if there are
 687 ;;; a variable number of arguments passed on the stack. Variable
 688 ;;; cannot be specified with :TAIL return. TR variable argument call
 689 ;;; is implemented separately.
 690 ;;;
 691 ;;; In tail call with fixed arguments, the passing locations are
 692 ;;; passed as a more arg, but there is no new-FP, since the arguments
 693 ;;; have been set up in the current frame.
 694 (macrolet ((define-full-call (name named return variable)
 695             (aver (not (and variable (eq return :tail))))
 696             `(define-vop (,name
 697                           ,@(when (eq return :unknown)
 698                               '(unknown-values-receiver)))
 699                (:args
 700                ,@(unless (eq return :tail)
 701                    '((new-fp :scs (any-reg) :to (:argument 1))))
 702
 703                (fun :scs (descriptor-reg control-stack)
 704                     :target rax :to (:argument 0))
 705
 706                ,@(when (eq return :tail)
 707                    '((old-fp)
 708                      (return-pc)))
 709
 710                ,@(unless variable '((args :more t :scs (descriptor-reg)))))
 711
 712                ,@(when (eq return :fixed)
 713                '((:results (values :more t))))
 714
 715                (:save-p ,(if (eq return :tail) :compute-only t))
 716
 717                ,@(unless (or (eq return :tail) variable)
 718                '((:move-args :full-call)))
 719
 720                (:vop-var vop)
 721                (:info
 722                ,@(unless (or variable (eq return :tail)) '(arg-locs))
 723                ,@(unless variable '(nargs))
 724                ,@(when (eq return :fixed) '(nvals)))
 725
 726                (:ignore
 727                ,@(unless (or variable (eq return :tail)) '(arg-locs))
 728                ,@(unless variable '(args)))
 729
 730                ;; We pass either the fdefn object (for named call) or
 731                ;; the actual function object (for unnamed call) in
 732                ;; RAX. With named call, closure-tramp will replace it
 733                ;; with the real function and invoke the real function
 734                ;; for closures. Non-closures do not need this value,
 735                ;; so don't care what shows up in it.
 736                (:temporary
 737                (:sc descriptor-reg
 738                     :offset rax-offset
 739                     :from (:argument 0)
 740                     :to :eval)
 741                rax)
 742
 743                ;; We pass the number of arguments in RCX.
 744                (:temporary (:sc unsigned-reg :offset rcx-offset :to :eval) rcx)
 745
 746                ;; With variable call, we have to load the
 747                ;; register-args out of the (new) stack frame before
 748                ;; doing the call. Therefore, we have to tell the
 749                ;; lifetime stuff that we need to use them.
 750                ,@(when variable
 751                    (mapcar (lambda (name offset)
 752                              `(:temporary (:sc descriptor-reg
 753                                                :offset ,offset
 754                                                :from (:argument 0)
 755                                                :to :eval)
 756                                           ,name))
 757                            *register-arg-names* *register-arg-offsets*))
 758
 759                ,@(when (eq return :tail)
 760                    '((:temporary (:sc unsigned-reg
 761                                       :from (:argument 1)
 762                                       :to (:argument 2))
 763                                  old-fp-tmp)))
 764
 765                (:generator ,(+ (if named 5 0)
 766                                (if variable 19 1)
 767                                (if (eq return :tail) 0 10)
 768                                15
 769                                (if (eq return :unknown) 25 0))
 770                (trace-table-entry trace-table-call-site)
 771
 772                ;; This has to be done before the frame pointer is
 773                ;; changed! RAX stores the 'lexical environment' needed
 774                ;; for closures.
 775                (move rax fun)
 776
 777
 778                ,@(if variable
 779                      ;; For variable call, compute the number of
 780                      ;; arguments and move some of the arguments to
 781                      ;; registers.
 782                      (collect ((noise))
 783                               ;; Compute the number of arguments.
 784                               (noise '(inst mov rcx new-fp))
 785                               (noise '(inst sub rcx rsp-tn))
 786                               ;; Move the necessary args to registers,
 787                               ;; this moves them all even if they are
 788                               ;; not all needed.
 789                               (loop
 790                                for name in *register-arg-names*
 791                                for index downfrom -1
 792                                do (noise `(loadw ,name new-fp ,index)))
 793                               (noise))
 794                    '((if (zerop nargs)
 795                          (inst xor rcx rcx)
 796                        (inst mov rcx (fixnumize nargs)))))
 797                ,@(cond ((eq return :tail)
 798                         '(;; Python has figured out what frame we should
 799                           ;; return to so might as well use that clue.
 800                           ;; This seems really important to the
 801                           ;; implementation of things like
 802                           ;; (without-interrupts ...)
 803                           ;;
 804                           ;; dtc; Could be doing a tail call from a
 805                           ;; known-local-call etc in which the old-fp
 806                           ;; or ret-pc are in regs or in non-standard
 807                           ;; places. If the passing location were
 808                           ;; wired to the stack in standard locations
 809                           ;; then these moves will be un-necessary;
 810                           ;; this is probably best for the x86.
 811                           (sc-case old-fp
 812                                    ((control-stack)
 813                                     (unless (= ocfp-save-offset
 814                                                (tn-offset old-fp))
 815                                       ;; FIXME: FORMAT T for stale
 816                                       ;; diagnostic output (several of
 817                                       ;; them around here), ick
 818                                       (format t "** tail-call old-fp not S0~%")
 819                                       (move old-fp-tmp old-fp)
 820                                       (storew old-fp-tmp
 821                                               rbp-tn
 822                                               (- (1+ ocfp-save-offset)))))
 823                                    ((any-reg descriptor-reg)
 824                                     (format t "** tail-call old-fp in reg not S0~%")
 825                                     (storew old-fp
 826                                             rbp-tn
 827                                             (- (1+ ocfp-save-offset)))))
 828
 829                           ;; For tail call, we have to push the
 830                           ;; return-pc so that it looks like we CALLed
 831                           ;; drspite the fact that we are going to JMP.
 832                           (inst push return-pc)
 833                           ))
 834                        (t
 835                         ;; For non-tail call, we have to save our
 836                         ;; frame pointer and install the new frame
 837                         ;; pointer. We can't load stack tns after this
 838                         ;; point.
 839                         `(;; Python doesn't seem to allocate a frame
 840                           ;; here which doesn't leave room for the
 841                           ;; ofp/ret stuff.
 842
 843                           ;; The variable args are on the stack and
 844                           ;; become the frame, but there may be <3
 845                           ;; args and 3 stack slots are assumed
 846                           ;; allocate on the call. So need to ensure
 847                           ;; there are at least 3 slots. This hack
 848                           ;; just adds 3 more.
 849                           ,(if variable
 850                                '(inst sub rsp-tn (fixnumize 3)))
 851
 852                           ;; Save the fp
 853                           (storew rbp-tn new-fp (- (1+ ocfp-save-offset)))
 854
 855                           (move rbp-tn new-fp) ; NB - now on new stack frame.
 856                           )))
 857
 858                (note-this-location vop :call-site)
 859
 860                (inst ,(if (eq return :tail) 'jmp 'call)
 861                      (make-ea :qword :base rax
 862                               :disp ,(if named
 863                                          '(- (* fdefn-raw-addr-slot
 864                                                 n-word-bytes)
 865                                              other-pointer-lowtag)
 866                                        '(- (* closure-fun-slot n-word-bytes)
 867                                            fun-pointer-lowtag))))
 868                ,@(ecase return
 869                    (:fixed
 870                     '((default-unknown-values vop values nvals)))
 871                    (:unknown
 872                     '((note-this-location vop :unknown-return)
 873                       (receive-unknown-values values-start nvals start count)))
 874                    (:tail))
 875                (trace-table-entry trace-table-normal)))))
 876
 877   (define-full-call call nil :fixed nil)
 878   (define-full-call call-named t  :fixed nil)
 879   (define-full-call multiple-call nil :unknown nil)
 880   (define-full-call multiple-call-named t :unknown nil)
 881   (define-full-call tail-call nil :tail nil)
 882   (define-full-call tail-call-named t :tail nil)
 883
 884   (define-full-call call-variable nil :fixed t)
 885   (define-full-call multiple-call-variable nil :unknown t))
 886
 887 ;;; This is defined separately, since it needs special code that BLT's
 888 ;;; the arguments down. All the real work is done in the assembly
 889 ;;; routine. We just set things up so that it can find what it needs.
 890 (define-vop (tail-call-variable)
 891   (:args (args :scs (any-reg control-stack) :target rsi)
 892          (function :scs (descriptor-reg control-stack) :target rax)
 893          (old-fp)
 894          (ret-addr))
 895   (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) rsi)
 896   (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
 897 ;  (:ignore ret-addr old-fp)
 898   (:generator 75
 899     ;; Move these into the passing locations if they are not already there.
 900     (move rsi args)
 901     (move rax function)
 902
 903     ;; The following assumes that the return-pc and old-fp are on the
 904     ;; stack in their standard save locations - Check this.
 905     (unless (and (sc-is old-fp control-stack)
 906                  (= (tn-offset old-fp) ocfp-save-offset))
 907             (error "tail-call-variable: ocfp not on stack in standard save location?"))
 908     (unless (and (sc-is ret-addr sap-stack)
 909                  (= (tn-offset ret-addr) return-pc-save-offset))
 910             (error "tail-call-variable: ret-addr not on stack in standard save location?"))
 911
 912
 913     ;; And jump to the assembly routine.
 914     (inst jmp (make-fixup 'tail-call-variable :assembly-routine))))
 915 \f
 916 ;;;; unknown values return
 917
 918 ;;; Return a single-value using the Unknown-Values convention. Specifically,
 919 ;;; we jump to clear the stack and jump to return-pc+3.
 920 ;;;
 921 ;;; We require old-fp to be in a register, because we want to reset RSP before
 922 ;;; restoring RBP. If old-fp were still on the stack, it could get clobbered
 923 ;;; by a signal.
 924 ;;;
 925 ;;; pfw--get wired-tn conflicts sometimes if register sc specd for args
 926 ;;; having problems targeting args to regs -- using temps instead.
 927 (define-vop (return-single)
 928   (:args (old-fp)
 929          (return-pc)
 930          (value))
 931   (:temporary (:sc unsigned-reg) ofp)
 932   (:temporary (:sc unsigned-reg) ret)
 933   (:ignore value)
 934   (:generator 6
 935     (trace-table-entry trace-table-fun-epilogue)
 936     (move ret return-pc)
 937     ;; Clear the control stack
 938     (move ofp old-fp)
 939     ;; Adjust the return address for the single value return.
 940     (inst add ret 3)
 941     ;; Restore the frame pointer.
 942     (move rsp-tn rbp-tn)
 943     (move rbp-tn ofp)
 944     ;; Out of here.
 945     (inst jmp ret)))
 946
 947 ;;; Do unknown-values return of a fixed (other than 1) number of
 948 ;;; values. The VALUES are required to be set up in the standard
 949 ;;; passing locations. NVALS is the number of values returned.
 950 ;;;
 951 ;;; Basically, we just load RCX with the number of values returned and
 952 ;;; RBX with a pointer to the values, set RSP to point to the end of
 953 ;;; the values, and jump directly to return-pc.
 954 (define-vop (return)
 955   (:args (old-fp)
 956          (return-pc :to (:eval 1))
 957          (values :more t))
 958   (:ignore values)
 959   (:info nvals)
 960
 961   ;; In the case of other than one value, we need these registers to
 962   ;; tell the caller where they are and how many there are.
 963   (:temporary (:sc unsigned-reg :offset rbx-offset) rbx)
 964   (:temporary (:sc unsigned-reg :offset rcx-offset) rcx)
 965
 966   ;; We need to stretch the lifetime of return-pc past the argument
 967   ;; registers so that we can default the argument registers without
 968   ;; trashing return-pc.
 969   (:temporary (:sc unsigned-reg :offset (first *register-arg-offsets*)
 970                    :from :eval) a0)
 971   (:temporary (:sc unsigned-reg :offset (second *register-arg-offsets*)
 972                    :from :eval) a1)
 973   (:temporary (:sc unsigned-reg :offset (third *register-arg-offsets*)
 974                    :from :eval) a2)
 975
 976   (:generator 6
 977     (trace-table-entry trace-table-fun-epilogue)
 978     ;; Establish the values pointer and values count.
 979     (move rbx rbp-tn)
 980     (if (zerop nvals)
 981         (inst xor rcx rcx) ; smaller
 982       (inst mov rcx (fixnumize nvals)))
 983     ;; Restore the frame pointer.
 984     (move rbp-tn old-fp)
 985     ;; Clear as much of the stack as possible, but not past the return
 986     ;; address.
 987     (inst lea rsp-tn (make-ea :qword :base rbx
 988                               :disp (- (* (max nvals 2) n-word-bytes))))
 989     ;; Pre-default any argument register that need it.
 990     (when (< nvals register-arg-count)
 991       (let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
 992              (first (first arg-tns)))
 993         (inst mov first nil-value)
 994         (dolist (tn (cdr arg-tns))
 995           (inst mov tn first))))
 996     ;; And away we go. Except that return-pc is still on the
 997     ;; stack and we've changed the stack pointer. So we have to
 998     ;; tell it to index off of RBX instead of RBP.
 999     (cond ((zerop nvals)
1000            ;; Return popping the return address and the OCFP.
1001            (inst ret n-word-bytes))
1002           ((= nvals 1)
1003            ;; Return popping the return, leaving 1 slot. Can this
1004            ;; happen, or is a single value return handled elsewhere?
1005            (inst ret))
1006           (t
1007            (inst jmp (make-ea :qword :base rbx
1008                               :disp (- (* (1+ (tn-offset return-pc))
1009                                           n-word-bytes))))))
1010
1011     (trace-table-entry trace-table-normal)))
1012
1013 ;;; Do unknown-values return of an arbitrary number of values (passed
1014 ;;; on the stack.) We check for the common case of a single return
1015 ;;; value, and do that inline using the normal single value return
1016 ;;; convention. Otherwise, we branch off to code that calls an
1017 ;;; assembly-routine.
1018 ;;;
1019 ;;; The assembly routine takes the following args:
1020 ;;;  RAX -- the return-pc to finally jump to.
1021 ;;;  RBX -- pointer to where to put the values.
1022 ;;;  RCX -- number of values to find there.
1023 ;;;  RSI -- pointer to where to find the values.
1024 (define-vop (return-multiple)
1025   (:args (old-fp :to (:eval 1) :target old-fp-temp)
1026          (return-pc :target rax)
1027          (vals :scs (any-reg) :target rsi)
1028          (nvals :scs (any-reg) :target rcx))
1029
1030   (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
1031   (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 2)) rsi)
1032   (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 3)) rcx)
1033   (:temporary (:sc unsigned-reg :offset rbx-offset :from (:eval 0)) rbx)
1034   (:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*)
1035                    :from (:eval 0)) a0)
1036   (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
1037   (:node-var node)
1038
1039   (:generator 13
1040     (trace-table-entry trace-table-fun-epilogue)
1041     ;; Load the return-pc.
1042     (move rax return-pc)
1043     (unless (policy node (> space speed))
1044       ;; Check for the single case.
1045       (let ((not-single (gen-label)))
1046         (inst cmp nvals (fixnumize 1))
1047         (inst jmp :ne not-single)
1048
1049         ;; Return with one value.
1050         (loadw a0 vals -1)
1051         ;; Clear the stack. We load old-fp into a register before clearing
1052         ;; the stack.
1053         (move old-fp-temp old-fp)
1054         (move rsp-tn rbp-tn)
1055         (move rbp-tn old-fp-temp)
1056         ;; Fix the return-pc to point at the single-value entry point.
1057         (inst add rax 3) ; skip "mov %rbx,%rsp" insn in caller
1058         ;; Out of here.
1059         (inst jmp rax)
1060
1061         ;; Nope, not the single case. Jump to the assembly routine.
1062         (emit-label not-single)))
1063     (move rsi vals)
1064     (move rcx nvals)
1065     (move rbx rbp-tn)
1066     (move rbp-tn old-fp)
1067     (inst jmp (make-fixup 'return-multiple :assembly-routine))
1068     (trace-table-entry trace-table-normal)))
1069 \f
1070 ;;;; XEP hackery
1071
1072 ;;; We don't need to do anything special for regular functions.
1073 (define-vop (setup-environment)
1074   (:info label)
1075   (:ignore label)
1076   (:generator 0
1077     ;; Don't bother doing anything.
1078     nil))
1079
1080 ;;; Get the lexical environment from its passing location.
1081 (define-vop (setup-closure-environment)
1082   (:results (closure :scs (descriptor-reg)))
1083   (:info label)
1084   (:ignore label)
1085   (:generator 6
1086     ;; Get result.
1087     (move closure rax-tn)))
1088
1089 ;;; Copy a &MORE arg from the argument area to the end of the current
1090 ;;; frame. FIXED is the number of non-&MORE arguments.
1091 ;;;
1092 ;;; The tricky part is doing this without trashing any of the calling
1093 ;;; convention registers that are still needed. This vop is emitted
1094 ;;; directly after the xep-allocate frame. That means the registers
1095 ;;; are in use as follows:
1096 ;;;
1097 ;;;  RAX -- The lexenv.
1098 ;;;  RBX -- Available.
1099 ;;;  RCX -- The total number of arguments.
1100 ;;;  RDX -- The first arg.
1101 ;;;  RDI -- The second arg.
1102 ;;;  RSI -- The third arg.
1103 ;;;
1104 ;;; So basically, we have one register available for our use: RBX.
1105 ;;;
1106 ;;; What we can do is push the other regs onto the stack, and then
1107 ;;; restore their values by looking directly below where we put the
1108 ;;; more-args.
1109 (define-vop (copy-more-arg)
1110   (:info fixed)
1111   (:generator 20
1112     ;; Avoid the copy if there are no more args.
1113     (cond ((zerop fixed)
1114            (inst jecxz just-alloc-frame))
1115           (t
1116            (inst cmp rcx-tn (fixnumize fixed))
1117            (inst jmp :be just-alloc-frame)))
1118
1119     ;; Allocate the space on the stack.
1120     ;; stack = rbp - (max 3 frame-size) - (nargs - fixed)
1121     (inst lea rbx-tn
1122           (make-ea :qword :base rbp-tn
1123                    :disp (- (fixnumize fixed)
1124                             (* n-word-bytes
1125                                (max 3 (sb-allocated-size 'stack))))))
1126     (inst sub rbx-tn rcx-tn)  ; Got the new stack in rbx
1127     (inst mov rsp-tn rbx-tn)
1128
1129     ;; Now: nargs>=1 && nargs>fixed
1130
1131     ;; Save the original count of args.
1132     (inst mov rbx-tn rcx-tn)
1133
1134     (cond ((< fixed register-arg-count)
1135            ;; We must stop when we run out of stack args, not when we
1136            ;; run out of more args.
1137            ;; Number to copy = nargs-3
1138            (inst sub rcx-tn (fixnumize register-arg-count))
1139            ;; Everything of interest in registers.
1140            (inst jmp :be do-regs))
1141           (t
1142            ;; Number to copy = nargs-fixed
1143            (inst sub rcx-tn (fixnumize fixed))))
1144
1145     ;; Save rdi and rsi register args.
1146     (inst push rdi-tn)
1147     (inst push rsi-tn)
1148     ;; Okay, we have pushed the register args. We can trash them
1149     ;; now.
1150
1151     ;; Initialize dst to be end of stack; skiping the values pushed
1152     ;; above.
1153     (inst lea rdi-tn (make-ea :qword :base rsp-tn :disp 16))
1154
1155     ;; Initialize src to be end of args.
1156     (inst mov rsi-tn rbp-tn)
1157     (inst sub rsi-tn rbx-tn)
1158
1159     (inst shr rcx-tn word-shift)        ; make word count
1160     ;; And copy the args.
1161     (inst cld)                          ; auto-inc RSI and RDI.
1162     (inst rep)
1163     (inst movs :qword)
1164
1165     ;; So now we need to restore RDI and RSI.
1166     (inst pop rsi-tn)
1167     (inst pop rdi-tn)
1168
1169     DO-REGS
1170
1171     ;; Restore RCX
1172     (inst mov rcx-tn rbx-tn)
1173
1174     ;; Here: nargs>=1 && nargs>fixed
1175     (when (< fixed register-arg-count)
1176           ;; Now we have to deposit any more args that showed up in
1177           ;; registers.
1178           (do ((i fixed))
1179               ( nil )
1180               ;; Store it relative to rbp
1181               (inst mov (make-ea :qword :base rbp-tn
1182                                  :disp (- (* n-word-bytes
1183                                              (+ 1 (- i fixed)
1184                                                 (max 3 (sb-allocated-size 'stack))))))
1185                     (nth i *register-arg-tns*))
1186
1187               (incf i)
1188               (when (>= i register-arg-count)
1189                     (return))
1190
1191               ;; Don't deposit any more than there are.
1192               (if (zerop i)
1193                   (inst test rcx-tn rcx-tn)
1194                 (inst cmp rcx-tn (fixnumize i)))
1195               (inst jmp :eq done)))
1196
1197     (inst jmp done)
1198
1199     JUST-ALLOC-FRAME
1200     (inst lea rsp-tn
1201           (make-ea :qword :base rbp-tn
1202                    :disp (- (* n-word-bytes
1203                                (max 3 (sb-allocated-size 'stack))))))
1204
1205     DONE))
1206
1207 ;;; &MORE args are stored contiguously on the stack, starting
1208 ;;; immediately at the context pointer. The context pointer is not
1209 ;;; typed, so the lowtag is 0.
1210 (define-vop (more-arg)
1211   (:translate %more-arg)
1212   (:policy :fast-safe)
1213   (:args (object :scs (descriptor-reg) :to :result)
1214          (index :scs (any-reg) :target temp))
1215   (:arg-types * tagged-num)
1216   (:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
1217   (:results (value :scs (any-reg descriptor-reg)))
1218   (:result-types *)
1219   (:generator 5
1220     (move temp index)
1221     (inst neg temp)
1222     (inst mov value (make-ea :qword :base object :index temp))))
1223
1224 (define-vop (more-arg-c)
1225   (:translate %more-arg)
1226   (:policy :fast-safe)
1227   (:args (object :scs (descriptor-reg)))
1228   (:info index)
1229   (:arg-types * (:constant (signed-byte 30)))
1230   (:results (value :scs (any-reg descriptor-reg)))
1231   (:result-types *)
1232   (:generator 4
1233    (inst mov value
1234          (make-ea :qword :base object :disp (- (* index n-word-bytes))))))
1235
1236
1237 ;;; Turn more arg (context, count) into a list.
1238 (define-vop (listify-rest-args)
1239   (:translate %listify-rest-args)
1240   (:policy :safe)
1241   (:args (context :scs (descriptor-reg) :target src)
1242          (count :scs (any-reg) :target rcx))
1243   (:arg-types * tagged-num)
1244   (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) src)
1245   (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
1246   (:temporary (:sc unsigned-reg :offset rax-offset) rax)
1247   (:temporary (:sc unsigned-reg) dst)
1248   (:results (result :scs (descriptor-reg)))
1249   (:node-var node)
1250   (:generator 20
1251     (let ((enter (gen-label))
1252           (loop (gen-label))
1253           (done (gen-label)))
1254       (move src context)
1255       (move rcx count)
1256       ;; Check to see whether there are no args, and just return NIL if so.
1257       (inst mov result nil-value)
1258       (inst jecxz done)
1259       (inst lea dst (make-ea :qword :index rcx :scale 2))
1260       (pseudo-atomic
1261        (allocation dst dst node)
1262        (inst lea dst (make-ea :byte :base dst :disp list-pointer-lowtag))
1263        ;; Convert the count into a raw value, so that we can use the
1264        ;; LOOP instruction.
1265        (inst shr rcx (1- n-word-bytes))
1266        ;; Set decrement mode (successive args at lower addresses)
1267        (inst std)
1268        ;; Set up the result.
1269        (move result dst)
1270        ;; Jump into the middle of the loop, 'cause that's where we want
1271        ;; to start.
1272        (inst jmp enter)
1273        (emit-label loop)
1274        ;; Compute a pointer to the next cons.
1275        (inst add dst (* cons-size n-word-bytes))
1276        ;; Store a pointer to this cons in the CDR of the previous cons.
1277        (storew dst dst -1 list-pointer-lowtag)
1278        (emit-label enter)
1279        ;; Grab one value and stash it in the car of this cons.
1280        (inst lods rax)
1281        (storew rax dst 0 list-pointer-lowtag)
1282        ;; Go back for more.
1283        (inst loop loop)
1284        ;; NIL out the last cons.
1285        (storew nil-value dst 1 list-pointer-lowtag))
1286       (emit-label done))))
1287
1288 ;;; Return the location and size of the &MORE arg glob created by
1289 ;;; COPY-MORE-ARG. SUPPLIED is the total number of arguments supplied
1290 ;;; (originally passed in RCX). FIXED is the number of non-rest
1291 ;;; arguments.
1292 ;;;
1293 ;;; We must duplicate some of the work done by COPY-MORE-ARG, since at
1294 ;;; that time the environment is in a pretty brain-damaged state,
1295 ;;; preventing this info from being returned as values. What we do is
1296 ;;; compute supplied - fixed, and return a pointer that many words
1297 ;;; below the current stack top.
1298 (define-vop (more-arg-context)
1299   (:policy :fast-safe)
1300   (:translate sb!c::%more-arg-context)
1301   (:args (supplied :scs (any-reg) :target count))
1302   (:arg-types positive-fixnum (:constant fixnum))
1303   (:info fixed)
1304   (:results (context :scs (descriptor-reg))
1305             (count :scs (any-reg)))
1306   (:result-types t tagged-num)
1307   (:note "more-arg-context")
1308   (:generator 5
1309     (move count supplied)
1310     ;; SP at this point points at the last arg pushed.
1311     ;; Point to the first more-arg, not above it.
1312     (inst lea context (make-ea :qword :base rsp-tn
1313                                :index count :scale 1
1314                                :disp (- (+ (fixnumize fixed) n-word-bytes))))
1315     (unless (zerop fixed)
1316       (inst sub count (fixnumize fixed)))))
1317
1318 ;;; Signal wrong argument count error if NARGS isn't equal to COUNT.
1319 (define-vop (verify-arg-count)
1320   (:policy :fast-safe)
1321   (:translate sb!c::%verify-arg-count)
1322   (:args (nargs :scs (any-reg)))
1323   (:arg-types positive-fixnum (:constant t))
1324   (:info count)
1325   (:vop-var vop)
1326   (:save-p :compute-only)
1327   (:generator 3
1328     (let ((err-lab
1329            (generate-error-code vop invalid-arg-count-error nargs)))
1330       (if (zerop count)
1331           (inst test nargs nargs)  ; smaller instruction
1332         (inst cmp nargs (fixnumize count)))
1333       (inst jmp :ne err-lab))))
1334
1335 ;;; Various other error signallers.
1336 (macrolet ((def (name error translate &rest args)
1337              `(define-vop (,name)
1338                 ,@(when translate
1339                     `((:policy :fast-safe)
1340                       (:translate ,translate)))
1341                 (:args ,@(mapcar (lambda (arg)
1342                                    `(,arg :scs (any-reg descriptor-reg)))
1343                                  args))
1344                 (:vop-var vop)
1345                 (:save-p :compute-only)
1346                 (:generator 1000
1347                   (error-call vop ,error ,@args)))))
1348   (def arg-count-error invalid-arg-count-error
1349     sb!c::%arg-count-error nargs)
1350   (def type-check-error object-not-type-error sb!c::%type-check-error
1351     object type)
1352   (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
1353     object layout)
1354   (def odd-key-args-error odd-key-args-error
1355     sb!c::%odd-key-args-error)
1356   (def unknown-key-arg-error unknown-key-arg-error
1357     sb!c::%unknown-key-arg-error key)
1358   (def nil-fun-returned-error nil-fun-returned-error nil fun))