;; The start of the actual code.
;; Save the return-pc.
- (popw ebp-tn (- (1+ return-pc-save-offset)))
+ (popw ebp-tn (frame-word-offset return-pc-save-offset))
;; If copy-more-arg follows it will allocate the correct stack
;; size. The stack is not allocated first here as this may expose
(inst cmp ecx-tn (fixnumize i))
(inst jmp :be default-lab)
- (loadw edx-tn ebx-tn (- (1+ i)))
+ (loadw edx-tn ebx-tn (frame-word-offset i))
(inst mov tn edx-tn)))
(emit-label defaulting-done)
(emit-label no-stack-args)
(inst lea edi-tn
(make-ea :dword :base ebp-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ :disp (frame-byte-offset register-arg-count)))
;; Load EAX with NIL so we can quickly store it, and set up
;; stuff for the loop.
(inst mov eax-tn nil-value)
;; and then default the remaining stack arguments.
(emit-label regs-defaulted)
;; Save EDI.
- (storew edi-tn ebx-tn (- (1+ 1)))
+ (storew edi-tn ebx-tn (frame-word-offset 1))
;; Compute the number of stack arguments, and if it's zero or
;; less, don't copy any stack arguments.
(inst sub ecx-tn (fixnumize register-arg-count))
;; Compute a pointer to where the stack args go.
(inst lea edi-tn
(make-ea :dword :base ebp-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ :disp (frame-byte-offset register-arg-count)))
;; Save ESI, and compute a pointer to where the args come from.
- (storew esi-tn ebx-tn (- (1+ 2)))
+ (storew esi-tn ebx-tn (frame-word-offset 2))
(inst lea esi-tn
(make-ea :dword :base ebx-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ :disp (frame-byte-offset register-arg-count)))
;; Do the copy.
(inst shr ecx-tn word-shift) ; make word count
(inst std)
;; solaris requires DF being zero.
#!+sunos (inst cld)
;; Restore ESI.
- (loadw esi-tn ebx-tn (- (1+ 2)))
+ (loadw esi-tn ebx-tn (frame-word-offset 2))
;; Now we have to default the remaining args. Find out how many.
(inst sub eax-tn (fixnumize (- nvals register-arg-count)))
(inst neg eax-tn)
#!+sunos (inst cld)
;; Restore EDI, and reset the stack.
(emit-label restore-edi)
- (loadw edi-tn ebx-tn (- (1+ 1)))
+ (loadw edi-tn ebx-tn (frame-word-offset 1))
(inst mov esp-tn ebx-tn))))
(values))
\f
#+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
(tn-offset ret-tn))
(storew (make-fixup nil :code-object return)
- ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ebp-tn (frame-word-offset (tn-offset ret-tn))))
((sap-reg)
(inst lea ret-tn (make-fixup nil :code-object return)))))
(tn-offset ret-tn))
;; Stack
(storew (make-fixup nil :code-object return)
- ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ebp-tn (frame-word-offset (tn-offset ret-tn))))
((sap-reg)
;; Register
(inst lea ret-tn (make-fixup nil :code-object return)))))
(tn-offset ret-tn))
;; Stack
(storew (make-fixup nil :code-object return)
- ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ebp-tn (frame-word-offset (tn-offset ret-tn))))
((sap-reg)
;; Register
(inst lea ret-tn (make-fixup nil :code-object return)))))
(cond ((zerop (tn-offset old-fp))
;; Zot all of the stack except for the old-fp.
(inst lea esp-tn (make-ea :dword :base ebp-tn
- :disp (- (* (1+ ocfp-save-offset)
- n-word-bytes))))
+ :disp (frame-byte-offset ocfp-save-offset)))
;; Restore the old fp from its save location on the stack,
;; and zot the stack.
(inst pop ebp-tn))
;; Zot all of the stack except for the old-fp and return-pc.
(inst lea esp-tn
(make-ea :dword :base ebp-tn
- :disp (- (* (1+ (tn-offset return-pc)) n-word-bytes))))
+ :disp (frame-byte-offset (tn-offset return-pc))))
;; Restore the old fp. old-fp may be either on the stack in its
;; save location or in a register, in either case this restores it.
(move ebp-tn old-fp)
(move old-fp-tmp old-fp)
(storew old-fp-tmp
ebp-tn
- (- (1+ ocfp-save-offset)))))
+ (frame-word-offset ocfp-save-offset))))
((any-reg descriptor-reg)
(format t "** tail-call old-fp in reg not S0~%")
(storew old-fp
ebp-tn
- (- (1+ ocfp-save-offset)))))
+ (frame-word-offset ocfp-save-offset))))
;; For tail call, we have to push the
;; return-pc so that it looks like we CALLed
'(inst sub esp-tn (fixnumize 3)))
;; Save the fp
- (storew ebp-tn new-fp (- (1+ ocfp-save-offset)))
+ (storew ebp-tn new-fp (frame-word-offset ocfp-save-offset))
(move ebp-tn new-fp) ; NB - now on new stack frame.
)))
;; Drop the stack above it and pop it off.
(cond ((zerop (tn-offset old-fp))
(inst lea esp-tn (make-ea :dword :base ebp-tn
- :disp (- (* (1+ ocfp-save-offset)
- n-word-bytes))))
+ :disp (frame-byte-offset ocfp-save-offset)))
(inst pop ebp-tn))
(t
;; Should this ever happen, we do the same as above, but
;; into a temp reg while we fix the stack.
;; Drop stack above return-pc
(inst lea esp-tn (make-ea :dword :base ebp-tn
- :disp (- (* (1+ (tn-offset return-pc))
- n-word-bytes))))
+ :disp (frame-byte-offset (tn-offset return-pc))))
;; Set single-value return flag
(inst clc)
;; Restore the old frame pointer
(inst ret))
(t
(inst jmp (make-ea :dword :base ebx
- :disp (- (* (1+ (tn-offset return-pc))
- n-word-bytes))))))
+ :disp (frame-byte-offset (tn-offset return-pc))))))
(trace-table-entry trace-table-normal)))
(character-stack
#!-sb-unicode
(inst mov
- (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4)))
+ ;; XXX: If the sb-unicode case needs to handle c-call,
+ ;; why does the non-unicode case not need to?
+ (make-ea :byte :base fp :disp (frame-byte-offset (tn-offset y)))
x)
#!+sb-unicode
(if (= (tn-offset fp) esp-offset)
(storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (frame-word-offset (tn-offset y))))))))
(define-move-vop move-character-arg :move-arg
(any-reg character-reg) (character-reg))
(:result-types *)
(:generator 5
(inst mov result (make-ea :dword :base sap
- :disp (- (* (1+ index) n-word-bytes))))))
+ :disp (frame-byte-offset index)))))
(define-vop (write-control-stack)
(:translate %set-stack-ref)
(:result-types *)
(:generator 5
(inst mov (make-ea :dword :base sap
- :disp (- (* (1+ index) n-word-bytes)))
+ :disp (frame-byte-offset index))
value)
(move result value)))
(macrolet ((ea-for-xf-stack (tn kind)
`(make-ea
:dword :base ebp-tn
- :disp (- (* (+ (tn-offset ,tn)
- (ecase ,kind (:single 1) (:double 2) (:long 3)))
- n-word-bytes)))))
+ :disp (frame-byte-offset
+ (+ (tn-offset ,tn)
+ (ecase ,kind (:single 0) (:double 1) (:long 2)))))))
(defun ea-for-sf-stack (tn)
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack (tn)
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
`(make-ea
:dword :base ,base
- :disp (- (* (+ (tn-offset ,tn)
- (* (ecase ,kind
- (:single 1)
- (:double 2)
- (:long 3))
- (ecase ,slot (:real 1) (:imag 2))))
- n-word-bytes)))))
+ :disp (frame-byte-offset
+ (+ (tn-offset ,tn)
+ -1
+ (* (ecase ,kind
+ (:single 1)
+ (:double 2)
+ (:long 3))
+ (ecase ,slot (:real 1) (:imag 2))))))))
(defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
(ea-for-cxf-stack tn :single :real base))
(defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
(inst fxch x)))))
(,stack-sc
(if (= (tn-offset fp) esp-offset)
+ ;; C-call
(let* ((offset (* (tn-offset y) n-word-bytes))
(ea (make-ea :dword :base fp :disp offset)))
(with-tn@fp-top(x)
(:double '((inst fstd ea)))
#!+long-float
(:long '((store-long-float ea))))))
+ ;; Lisp stack
(let ((ea (make-ea
:dword :base fp
- :disp (- (* (+ (tn-offset y)
- ,(case format
- (:single 1)
- (:double 2)
- (:long 3)))
- n-word-bytes)))))
+ :disp (frame-byte-offset
+ (+ (tn-offset y)
+ ,(case format
+ (:single 0)
+ (:double 1)
+ (:long 2)))))))
(with-tn@fp-top(x)
,@(ecase format
(:single '((inst fst ea)))
(:policy :fast-safe)
(:vop-var vop)
(:generator 2
- (let ((offset (1+ (tn-offset temp))))
- (storew hi-bits ebp-tn (- offset))
- (storew lo-bits ebp-tn (- (1+ offset)))
+ (let ((offset (tn-offset temp)))
+ (storew hi-bits ebp-tn (frame-word-offset offset))
+ (storew lo-bits ebp-tn (frame-word-offset (1+ offset)))
(with-empty-tn@fp-top(res)
(inst fldd (make-ea :dword :base ebp-tn
- :disp (- (* (1+ offset) n-word-bytes))))))))
+ :disp (frame-byte-offset (1+ offset))))))))
#!+long-float
(define-vop (make-long-float)
(:policy :fast-safe)
(:vop-var vop)
(:generator 3
- (let ((offset (1+ (tn-offset temp))))
- (storew exp-bits ebp-tn (- offset))
- (storew hi-bits ebp-tn (- (1+ offset)))
- (storew lo-bits ebp-tn (- (+ offset 2)))
+ (let ((offset (tn-offset temp)))
+ (storew exp-bits ebp-tn (frame-word-offset offset))
+ (storew hi-bits ebp-tn (frame-word-offset (1+ offset)))
+ (storew lo-bits ebp-tn (frame-word-offset (+ offset 2)))
(with-empty-tn@fp-top(res)
(inst fldl (make-ea :dword :base ebp-tn
- :disp (- (* (+ offset 2) n-word-bytes))))))))
+ :disp (frame-byte-offset (+ offset 2))))))))
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
(double-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 2 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (1+ (tn-offset temp))))))
(inst fstd where)))
- (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
+ (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp))))
(double-stack
- (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
+ (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
(descriptor-reg
(loadw hi-bits float (1+ double-float-value-slot)
other-pointer-lowtag)))))
(double-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 2 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (1+ (tn-offset temp))))))
(inst fstd where)))
- (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
+ (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
(double-stack
- (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
+ (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float)))))
(descriptor-reg
(loadw lo-bits float double-float-value-slot
other-pointer-lowtag)))))
(long-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
(store-long-float where)))
(inst movsx exp-bits
(make-ea :word :base ebp-tn
- :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
+ :disp (frame-byte-offset (tn-offset temp)))))
(long-stack
(inst movsx exp-bits
(make-ea :word :base ebp-tn
- :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
+ :disp (frame-byte-offset (tn-offset temp)))))
(descriptor-reg
(inst movsx exp-bits
(make-ea :word :base float
(long-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
(store-long-float where)))
- (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
+ (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
(long-stack
- (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
+ (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
(descriptor-reg
(loadw hi-bits float (1+ long-float-value-slot)
other-pointer-lowtag)))))
(long-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
(store-long-float where)))
- (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
+ (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2))))
(long-stack
- (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
+ (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2))))
(descriptor-reg
(loadw lo-bits float long-float-value-slot
other-pointer-lowtag)))))
(emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
(stack
;; Convert stack tns into an index off of EBP.
- (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
+ (let ((disp (frame-byte-offset (tn-offset thing))))
(cond ((<= -128 disp 127)
(emit-mod-reg-r/m-byte segment #b01 reg #b101)
(emit-byte segment disp))
character-widetag)))))
(move y x)))
((control-stack)
- (if (sc-is x immediate)
- (let ((val (tn-value x)))
- (if (= (tn-offset fp) esp-offset)
- ;; C-call
- (etypecase val
- (integer
- (storew (fixnumize val) fp (tn-offset y)))
- (symbol
- (storew (+ nil-value (static-symbol-offset val))
- fp (tn-offset y)))
- (character
- (storew (logior (ash (char-code val) n-widetag-bits)
- character-widetag)
- fp (tn-offset y))))
- ;; Lisp stack
+ (let ((frame-offset (if (= (tn-offset fp) esp-offset)
+ ;; C-call
+ (tn-offset y)
+ ;; Lisp stack
+ (frame-word-offset (tn-offset y)))))
+ (if (sc-is x immediate)
+ (let ((val (tn-value x)))
(etypecase val
(integer
- (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
+ (storew (fixnumize val) fp frame-offset))
(symbol
(storew (+ nil-value (static-symbol-offset val))
- fp (- (1+ (tn-offset y)))))
+ fp frame-offset))
(character
(storew (logior (ash (char-code val) n-widetag-bits)
character-widetag)
- fp (- (1+ (tn-offset y))))))))
- (if (= (tn-offset fp) esp-offset)
- ;; C-call
- (storew x fp (tn-offset y))
- ;; Lisp stack
- (storew x fp (- (1+ (tn-offset y))))))))))
+ fp frame-offset))))
+ (storew x fp frame-offset)))))))
(define-move-vop move-arg :move-arg
(any-reg descriptor-reg)
((signed-stack unsigned-stack)
(if (= (tn-offset fp) esp-offset)
(storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (frame-word-offset (tn-offset y))))))))
(define-move-vop move-word-arg :move-arg
(descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
(defun catch-block-ea (tn)
(aver (sc-is tn catch-block))
(make-ea :dword :base ebp-tn
- :disp (- (* (+ (tn-offset tn) catch-block-size) n-word-bytes))))
+ :disp (frame-byte-offset (+ -1 (tn-offset tn) catch-block-size))))
\f
;;;; Save and restore dynamic environment.
(inst jmp :le default-lab)
(sc-case tn
((descriptor-reg any-reg)
- (loadw tn start (- (1+ i))))
+ (loadw tn start (frame-word-offset i)))
((control-stack)
- (loadw move-temp start (- (1+ i)))
+ (loadw move-temp start (frame-word-offset i))
(inst mov tn move-temp)))))
(let ((defaulting-done (gen-label)))
(emit-label defaulting-done)
(sap-stack
(if (= (tn-offset fp) esp-offset)
(storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (frame-word-offset (tn-offset y))))))))
(define-move-vop move-sap-arg :move-arg
(descriptor-reg sap-reg) (sap-reg))
;;; offsets of special stack frame locations
(def!constant ocfp-save-offset 0)
(def!constant return-pc-save-offset 1)
-(def!constant code-save-offset 2)
+
+(declaim (inline frame-word-offset))
+(defun frame-word-offset (index)
+ (- (1+ index)))
+
+(declaim (inline frame-byte-offset))
+(defun frame-byte-offset (index)
+ (* (frame-word-offset index) n-word-bytes))
;;; FIXME: This is a bad comment (changed since when?) and there are others
;;; like it in this file. It'd be nice to clarify them. Failing that deleting
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.41"
+"1.0.4.42"