;;; Return a wired TN describing the N'th full call argument passing
;;; location.
-(!def-vm-support-routine standard-arg-location (n)
+(defun standard-arg-location (n)
(declare (type unsigned-byte n))
(if (< n register-arg-count)
(make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number
;;;
;;; Always wire the return PC location to the stack in its standard
;;; location.
-(!def-vm-support-routine make-return-pc-passing-location (standard)
+(defun make-return-pc-passing-location (standard)
(declare (ignore standard))
(make-wired-tn (primitive-type-or-lose 'system-area-pointer)
sap-stack-sc-number return-pc-save-offset))
;;; because we want to be able to assume it's always there. Besides,
;;; the x86 doesn't have enough registers to really make it profitable
;;; to pass it in a register.
-(!def-vm-support-routine make-old-fp-passing-location (standard)
+(defun make-old-fp-passing-location (standard)
(declare (ignore standard))
(make-wired-tn *fixnum-primitive-type* control-stack-sc-number
ocfp-save-offset))
;;;
;;; Without using a save-tn - which does not make much sense if it is
;;; wired to the stack?
-(!def-vm-support-routine make-old-fp-save-location (physenv)
+(defun make-old-fp-save-location (physenv)
(physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type*
control-stack-sc-number
ocfp-save-offset)
physenv))
-(!def-vm-support-routine make-return-pc-save-location (physenv)
+(defun make-return-pc-save-location (physenv)
(physenv-debug-live-tn
(make-wired-tn (primitive-type-or-lose 'system-area-pointer)
sap-stack-sc-number return-pc-save-offset)
;;; Make a TN for the standard argument count passing location. We only
;;; need to make the standard location, since a count is never passed when we
;;; are using non-standard conventions.
-(!def-vm-support-routine make-arg-count-location ()
+(defun make-arg-count-location ()
(make-wired-tn *fixnum-primitive-type* any-reg-sc-number ecx-offset))
;;; Make a TN to hold the number-stack frame pointer. This is allocated
;;; once per component, and is component-live.
-(!def-vm-support-routine make-nfp-tn ()
+(defun make-nfp-tn ()
(make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
-(!def-vm-support-routine make-stack-pointer-tn ()
+(defun make-stack-pointer-tn ()
(make-normal-tn *fixnum-primitive-type*))
-(!def-vm-support-routine make-number-stack-pointer-tn ()
+(defun make-number-stack-pointer-tn ()
(make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
;;; Return a list of TNs that can be used to represent an unknown-values
;;; continuation within a function.
-(!def-vm-support-routine make-unknown-values-locations ()
+(defun make-unknown-values-locations ()
(list (make-stack-pointer-tn)
(make-normal-tn *fixnum-primitive-type*)))
;;; VM-dependent initialization of the IR2-COMPONENT structure. We
;;; push placeholder entries in the CONSTANTS to leave room for
;;; additional noise in the code object header.
-(!def-vm-support-routine select-component-format (component)
+(defun select-component-format (component)
(declare (type component component))
;; The 1+ here is because for the x86 the first constant is a
;; pointer to a list of fixups, or NIL if the code object has none.
(:generator 1
nil))
+;;; Accessing a slot from an earlier stack frame is definite hackery.
+(define-vop (ancestor-frame-ref)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (variable-home-tn :load-if nil))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (sc-is variable-home-tn control-stack))
+ (loadw value frame-pointer
+ (frame-word-offset (tn-offset variable-home-tn)))))
+(define-vop (ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg)))
+ (:results (variable-home-tn :load-if nil))
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (sc-is variable-home-tn control-stack))
+ (storew value frame-pointer
+ (frame-word-offset (tn-offset variable-home-tn)))))
+
+(macrolet ((define-frame-op
+ (suffix sc stack-sc instruction
+ &optional (ea
+ `(make-ea :dword
+ :base frame-pointer
+ :disp (frame-byte-offset
+ (tn-offset variable-home-tn)))))
+ (let ((reffer (symbolicate 'ancestor-frame-ref '/ suffix))
+ (setter (symbolicate 'ancestor-frame-set '/ suffix)))
+ `(progn
+ (define-vop (,reffer ancestor-frame-ref)
+ (:results (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ (inst ,instruction value
+ ,ea)))
+ (define-vop (,setter ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ (inst ,instruction ,ea value))))))
+ (define-x87-frame-op
+ (suffix sc stack-sc (load set)
+ &optional (ea
+ `(make-ea :dword
+ :base frame-pointer
+ :disp (frame-byte-offset
+ (tn-offset variable-home-tn)))))
+ (let ((reffer (symbolicate 'ancestor-frame-ref '/ suffix))
+ (setter (symbolicate 'ancestor-frame-set '/ suffix)))
+ `(progn
+ (define-vop (,reffer ancestor-frame-ref)
+ (:results (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ ,(if (symbolp load)
+ `(with-empty-tn@fp-top (value)
+ (inst ,load ,ea))
+ load)))
+ (define-vop (,setter ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ ,(if (symbolp set)
+ `(with-tn@fp-top (value)
+ (inst ,set ,ea))
+ set)))))))
+ (define-frame-op signed-byte-32 signed-reg signed-stack mov)
+ (define-frame-op unsigned-byte-32 unsigned-reg unsigned-stack mov)
+ (define-frame-op system-area-pointer sap-reg sap-stack mov)
+
+ (define-x87-frame-op double-float double-reg double-stack
+ (fldd fstd) (make-ea :dword
+ :base frame-pointer
+ :disp (frame-byte-offset
+ (1+ (tn-offset variable-home-tn)))))
+ (define-x87-frame-op single-float single-reg single-stack
+ (fld fst))
+
+ (define-x87-frame-op complex-double-float complex-double-reg
+ complex-double-stack
+ ((let ((real (complex-double-reg-real-tn value))
+ (imag (complex-double-reg-imag-tn value)))
+ (with-empty-tn@fp-top (real)
+ (inst fldd (ea-for-cdf-real-stack variable-home-tn frame-pointer)))
+ (with-empty-tn@fp-top (imag)
+ (inst fldd (ea-for-cdf-imag-stack variable-home-tn frame-pointer))))
+ (let ((real (complex-double-reg-real-tn value))
+ (imag (complex-double-reg-imag-tn value)))
+ (with-tn@fp-top (real)
+ (inst fstd (ea-for-cdf-real-stack variable-home-tn frame-pointer)))
+ (with-tn@fp-top (imag)
+ (inst fstd (ea-for-cdf-imag-stack variable-home-tn frame-pointer))))))
+ (define-x87-frame-op complex-single-float complex-single-reg
+ complex-single-stack
+ ((let ((real (complex-single-reg-real-tn value))
+ (imag (complex-single-reg-imag-tn value)))
+ (with-empty-tn@fp-top (real)
+ (inst fld (ea-for-csf-real-stack variable-home-tn frame-pointer)))
+ (with-empty-tn@fp-top (imag)
+ (inst fld (ea-for-csf-imag-stack variable-home-tn frame-pointer))))
+ (let ((real (complex-single-reg-real-tn value))
+ (imag (complex-single-reg-imag-tn value)))
+ (with-tn@fp-top (real)
+ (inst fst (ea-for-csf-real-stack variable-home-tn frame-pointer)))
+ (with-tn@fp-top (imag)
+ (inst fst (ea-for-csf-imag-stack variable-home-tn frame-pointer)))))))
+
+(defun primitive-type-indirect-cell-type (ptype)
+ (declare (type primitive-type ptype))
+ (macrolet ((foo (&body data)
+ `(case (primitive-type-name ptype)
+ ,@(loop for (name stack-sc ref set) in data
+ collect
+ `(,name
+ (load-time-value
+ (list (primitive-type-or-lose ',name)
+ (sc-or-lose ',stack-sc)
+ (lambda (node block fp value res)
+ (sb!c::vop ,ref node block
+ fp value res))
+ (lambda (node block fp new-val value)
+ (sb!c::vop ,set node block
+ fp new-val value)))))))))
+ (foo (double-float double-stack
+ ancestor-frame-ref/double-float
+ ancestor-frame-set/double-float)
+ (single-float single-stack
+ ancestor-frame-ref/single-float
+ ancestor-frame-set/single-float)
+ (complex-double-float complex-double-stack
+ ancestor-frame-ref/complex-double-float
+ ancestor-frame-set/complex-double-float)
+ (complex-single-float complex-single-stack
+ ancestor-frame-ref/complex-single-float
+ ancestor-frame-set/complex-single-float)
+ (signed-byte-32 signed-stack
+ ancestor-frame-ref/signed-byte-32
+ ancestor-frame-set/signed-byte-32)
+ (unsigned-byte-32 unsigned-stack
+ ancestor-frame-ref/unsigned-byte-32
+ ancestor-frame-set/unsigned-byte-32)
+ (unsigned-byte-31 unsigned-stack
+ ancestor-frame-ref/unsigned-byte-32
+ ancestor-frame-set/unsigned-byte-32)
+ (system-area-pointer sap-stack
+ ancestor-frame-ref/system-area-pointer
+ ancestor-frame-set/system-area-pointer))))
+
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
(:vop-var vop)
(= (tn-offset return-pc) return-pc-save-offset))
(error "return-pc not on stack in standard save location?")))
+;;; The local call convention doesn't fit that well with x86-style
+;;; calls. Emit a header for local calls to pop the return address
+;;; in the right place.
+(defun emit-block-header (start-label trampoline-label fall-thru-p alignp)
+ (declare (ignore alignp))
+ (when trampoline-label
+ (when fall-thru-p
+ (inst jmp start-label))
+ (emit-label trampoline-label)
+ (popw ebp-tn (frame-word-offset return-pc-save-offset)))
+ (emit-label start-label))
+
;;; Non-TR local call for a fixed number of values passed according to
;;; the unknown values convention.
;;;
(:move-args :local-call)
(:info arg-locs callee target nvals)
(:vop-var vop)
- (:ignore nfp arg-locs args #+nil callee)
+ (:ignore nfp arg-locs args callee)
(:node-var node)
(:generator 5
(trace-table-entry trace-table-call-site)
(move ebp-tn fp)
-
- (let ((ret-tn (callee-return-pc-tn callee)))
- #+nil
- (format t "*call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
-
- ;; Is the return-pc on the stack or in a register?
- (sc-case ret-tn
- ((sap-stack)
- (unless (= (tn-offset ret-tn) return-pc-save-offset)
- (error "ret-tn ~A in wrong stack slot" ret-tn))
- #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- (storew (make-fixup nil :code-object RETURN)
- ebp-tn (frame-word-offset (tn-offset ret-tn))))
- (t
- (error "ret-tn ~A in sap-reg" ret-tn))))
-
(note-this-location vop :call-site)
- (inst jmp target)
- RETURN
+ (inst call target)
(default-unknown-values vop values nvals node)
(trace-table-entry trace-table-normal)))
(:save-p t)
(:move-args :local-call)
(:info save callee target)
- (:ignore args save nfp #+nil callee)
+ (:ignore args save nfp callee)
(:vop-var vop)
(:node-var node)
(:generator 20
(trace-table-entry trace-table-call-site)
(move ebp-tn fp)
-
- (let ((ret-tn (callee-return-pc-tn callee)))
- #+nil
- (format t "*multiple-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
-
- ;; Is the return-pc on the stack or in a register?
- (sc-case ret-tn
- ((sap-stack)
- #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- ;; Stack
- (storew (make-fixup nil :code-object RETURN)
- ebp-tn (frame-word-offset (tn-offset ret-tn))))
- (t
- (error "multiple-call-local: return-pc not on stack."))))
-
(note-this-location vop :call-site)
- (inst jmp target)
- RETURN
+ (inst call target)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count node)
(trace-table-entry trace-table-normal)))
(:move-args :local-call)
(:save-p t)
(:info save callee target)
- (:ignore args res save nfp #+nil callee)
+ (:ignore args res save nfp callee)
(:vop-var vop)
(:generator 5
(trace-table-entry trace-table-call-site)
(move ebp-tn fp)
-
- (let ((ret-tn (callee-return-pc-tn callee)))
-
- #+nil
- (format t "*known-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
-
- ;; Is the return-pc on the stack or in a register?
- (sc-case ret-tn
- ((sap-stack)
- #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- ;; Stack
- (storew (make-fixup nil :code-object RETURN)
- ebp-tn (frame-word-offset (tn-offset ret-tn))))
- (t
- (error "known-call-local: return-pc not on stack."))))
-
(note-this-location vop :call-site)
- (inst jmp target)
- RETURN
+ (inst call target)
(note-this-location vop :known-return)
(trace-table-entry trace-table-normal)))
\f
;; Allocate the space on the stack.
;; stack = ebp + sp->fp-offset - (max 3 frame-size) - (nargs - fixed)
+ ;;
+ ;; Problem: this might leave some &more args outside esp, so
+ ;; clamp the movement for now. If fixed > frame-size, reset
+ ;; esp to the end of the current &more args (which *should*
+ ;; be a noop?), and only set esp to its final value after the
+ ;; stack-stack memmove loop. Otherwise, an unlucky signal
+ ;; could end up overwriting the &more arguments before they're
+ ;; moved in their final place.
(inst lea ebx-tn
(make-ea :dword :base ebp-tn
- :disp (* n-word-bytes
- (- (+ sp->fp-offset fixed)
- (max 3 (sb-allocated-size 'stack))))))
- (inst sub ebx-tn ecx-tn) ; Got the new stack in ebx
+ :disp (* n-word-bytes
+ (- sp->fp-offset
+ (max 0
+ (- (max 3 (sb-allocated-size 'stack))
+ fixed))))))
+ (inst sub ebx-tn ecx-tn) ; Got the new stack in ebx
(inst mov esp-tn ebx-tn)
;; Now: nargs>=1 && nargs>fixed
;; Number to copy = nargs-fixed
(inst sub ecx-tn (fixnumize fixed))))
- ;; Save edi and esi register args.
- (inst push edi-tn)
- (inst push esi-tn)
- (inst push ebx-tn)
- ;; Okay, we have pushed the register args. We can trash them
- ;; now.
-
- ;; Initialize src to be end of args.
- (inst lea esi-tn (make-ea :dword :base ebp-tn
- :disp (* sp->fp-offset n-word-bytes)))
- (inst sub esi-tn ebx-tn)
-
- ;; We need to copy from downwards up to avoid overwriting some of
- ;; the yet uncopied args. So we need to use EBX as the copy index
- ;; and ECX as the loop counter, rather than using ECX for both.
- (inst xor ebx-tn ebx-tn)
-
- ;; We used to use REP MOVS here, but on modern x86 it performs
- ;; much worse than an explicit loop for small blocks.
- COPY-LOOP
- (inst mov edi-tn (make-ea :dword :base esi-tn :index ebx-tn))
- ;; The :DISP is to account for the registers saved on the stack
- (inst mov (make-ea :dword :base esp-tn :disp (* 3 n-word-bytes)
- :index ebx-tn)
- edi-tn)
- (inst add ebx-tn n-word-bytes)
- (inst sub ecx-tn n-word-bytes)
- (inst jmp :nz COPY-LOOP)
-
- ;; So now we need to restore EDI and ESI.
- (inst pop ebx-tn)
- (inst pop esi-tn)
- (inst pop edi-tn)
-
+ (let ((delta (* n-word-bytes
+ (- (max 3 (sb-allocated-size 'stack))
+ fixed)))
+ (LOOP (gen-label)))
+ (cond ((zerop delta)
+ ;; nothing to move!
+ )
+ ((minusp delta)
+ ;; stack frame smaller than fixed; moving args to higher
+ ;; addresses (stack grows downard), so copy from the
+ ;; end. Moreover, because we'd have to shrink the frame,
+ ;; esp currently points at the end of the source args.
+ (inst push ebx-tn)
+
+ (emit-label LOOP)
+ (inst sub ecx-tn n-word-bytes)
+ (inst mov ebx-tn (make-ea :dword
+ :base esp-tn :index ecx-tn
+ ;; compensate for PUSH above
+ :disp n-word-bytes))
+ (inst mov (make-ea :dword
+ :base esp-tn :index ecx-tn
+ ;; compensate for PUSH, and
+ ;; add (abs delta)
+ :disp (- n-word-bytes delta))
+ ebx-tn)
+ (inst jmp :nz LOOP)
+
+ (inst pop ebx-tn))
+ ((plusp delta)
+ ;; stack frame larger than fixed. Moving args to lower
+ ;; addresses, so copy from the lowest address. esp
+ ;; already points to the lowest address of the destination.
+ (inst push ebx-tn)
+ (inst push esi-tn)
+
+ (inst xor ebx-tn ebx-tn)
+ (emit-label LOOP)
+ (inst mov esi-tn (make-ea :dword
+ :base esp-tn :index ebx-tn
+ ;; PUSHed 2 words
+ :disp (+ (* 2 n-word-bytes)
+ delta)))
+ (inst mov (make-ea :dword
+ :base esp-tn :index ebx-tn
+ :disp (* 2 n-word-bytes))
+ esi-tn)
+ (inst add ebx-tn n-word-bytes)
+ (inst sub ecx-tn n-word-bytes)
+ (inst jmp :nz LOOP)
+
+ (inst pop esi-tn)
+ (inst pop ebx-tn))))
DO-REGS
+ ;; stack can now be set to its final size
+ (when (< (max 3 (sb-allocated-size 'stack)) fixed)
+ (inst add esp-tn (* n-word-bytes
+ (- fixed
+ (max 3 (sb-allocated-size 'stack))))))
;; Restore ECX
(inst mov ecx-tn ebx-tn)
(inst lea dst (make-ea :dword :base ecx :index ecx))
(maybe-pseudo-atomic stack-allocate-p
(allocation dst dst node stack-allocate-p list-pointer-lowtag)
- (inst shr ecx (1- n-lowtag-bits))
;; Set decrement mode (successive args at lower addresses)
(inst std)
;; Set up the result.
(inst lods eax)
(storew eax dst 0 list-pointer-lowtag)
;; Go back for more.
- (inst sub ecx 1)
+ (inst sub ecx n-word-bytes)
(inst jmp :nz loop)
;; NIL out the last cons.
(storew nil-value dst 1 list-pointer-lowtag)
;; register on -SB-THREAD.
#!+sb-thread
(progn
- (inst cmp (make-ea :dword
- :disp (* thread-stepping-slot n-word-bytes))
- nil-value :fs))
+ #!+win32 (inst push eax-tn)
+ (with-tls-ea (EA :base #!+win32 eax-tn #!-win32 :unused
+ :disp-type :constant
+ :disp (* thread-stepping-slot n-word-bytes))
+ (inst cmp EA nil-value :maybe-fs))
+ #!+win32 (inst pop eax-tn))
#!-sb-thread
(inst cmp (make-ea-for-symbol-value sb!impl::*stepping*)
nil-value))
projects / sbcl.git / blobdiff