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