Forward port of Alastair Bridgewater's patch.
Duplicate it on x86-64.
Make it so that fp points to ocfp just as if the call had been made by
CALL to a function with the standard prologue "PUSH EBP; MOV ESP,
EBP".
Fix the debugger.
* bug fix: RESTART-FRAME and RETURN-FROM-FRAME stack corruption
* bug fix: the discriminating function for PRINT-OBJECT no longer preserves
potentially-invalid effective methods in its cache.
+ * improvement: on x86/x86-64 Lisp call frames now have the same layout as C
+ frames, allowing for instance more reliable backtraces.
changes in sbcl-1.0.27 relative to 1.0.26:
* new port: support added for x86-64 OpenBSD. (thanks to Josh Elsasser)
possibly converting any @code{&rest} arguments to a proper list.
The above scheme was changed in 1.0.27 on x86 and x86-64 by swapping
-the old frame pointer and the return address.
+the old frame pointer with the return address and making EBP point two
+words later:
+
+On x86/x86-64 the stack now looks like this (stack grows downwards):
+
+@verbatim
+----------
+RETURN PC
+----------
+OLD FP
+---------- <- FP points here
+EMPTY SLOT
+----------
+FIRST ARG
+----------
+@end verbatim
+
+just as if the function had been CALLed and upon entry executed the
+standard prologue: PUSH EBP; MOV EBP, ESP. On other architectures the
+stack looks like this (stack grows upwards):
+
+@verbatim
+----------
+FIRST ARG
+----------
+EMPTY SLOT
+----------
+RETURN PC
+----------
+OLD FP
+---------- <- FP points here
+@end verbatim
+
@node Unknown-Values Returns
@comment node-name, next, previous, up
(inst ret)
DO-STATIC-FUN
+ ;; Same as: (inst enter (fixnumize 1))
(inst push rbp-tn)
- (inst lea rbp-tn (make-ea :qword
- :base rsp-tn
- :disp (* 2 n-word-bytes)))
+ (inst mov rbp-tn rsp-tn)
(inst sub rsp-tn (fixnumize 1))
- (inst push (make-ea :qword :base rbp-tn :disp (- n-word-bytes)))
+ (inst push (make-ea :qword :base rbp-tn
+ :disp (frame-byte-offset return-pc-save-offset)))
(inst mov rcx (fixnumize 2)) ; arg count
(inst jmp
(make-ea :qword
(inst jmp :z FIXNUM)
(inst push rbp-tn)
- (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp (* 2 n-word-bytes)))
+ (inst mov rbp-tn rsp-tn)
(inst sub rsp-tn (fixnumize 1))
- (inst push (make-ea :qword :base rbp-tn :disp (- n-word-bytes)))
+ (inst push (make-ea :qword :base rbp-tn
+ :disp (frame-byte-offset return-pc-save-offset)))
(inst mov rcx (fixnumize 1)) ; arg count
(inst jmp (make-ea :qword
:disp (+ nil-value (static-fun-offset '%negate))))
(inst ret)
DO-STATIC-FUN
- (move rcx rsp-tn)
(inst sub rsp-tn (fixnumize 3))
- (inst mov (make-ea :qword
- :base rcx
- :disp (frame-byte-offset ocfp-save-offset))
+ (inst mov (make-ea :qword :base rsp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))
rbp-tn)
- (move rbp-tn rcx)
+ (inst lea rbp-tn (make-ea :qword :base rsp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset))))
(inst mov rcx (fixnumize 2))
(inst call (make-ea :qword
:disp (+ nil-value
(inst ret)
DO-STATIC-FUN
- (move rcx rsp-tn)
(inst sub rsp-tn (fixnumize 3))
- (inst mov (make-ea :qword
- :base rcx
- :disp (frame-byte-offset ocfp-save-offset))
+ (inst mov (make-ea :qword :base rsp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))
rbp-tn)
- (move rbp-tn rcx)
+ (inst lea rbp-tn (make-ea :qword :base rsp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset))))
(inst mov rcx (fixnumize 2))
(inst call (make-ea :qword
:disp (+ nil-value (static-fun-offset 'eql))))
(inst ret)
DO-STATIC-FUN
- (move rcx rsp-tn)
(inst sub rsp-tn (fixnumize 3))
- (inst mov (make-ea :qword
- :base rcx
- :disp (frame-byte-offset ocfp-save-offset))
+ (inst mov (make-ea :qword :base rsp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))
rbp-tn)
- (move rbp-tn rcx)
+ (inst lea rbp-tn (make-ea :qword :base rsp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset))))
+
(inst mov rcx (fixnumize 2))
(inst call (make-ea :qword
:disp (+ nil-value (static-fun-offset 'two-arg-=))))
(inst cmp ecx (fixnumize 3))
(inst jmp :e THREE-VALUES)
- (inst mov ebx rbp-tn)
- ;; Save the count, because the loop is going to destroy it.
+ ;; As per the calling convention EBX is expected to point at the SP
+ ;; before the stack frame.
+ (inst lea ebx (make-ea :qword :base rbp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
+
+ ;; Save the count, the return address and restore the frame pointer,
+ ;; because the loop is going to destroy them.
(inst mov edx ecx)
(inst mov eax (make-ea :qword :base rbp-tn
:disp (frame-byte-offset return-pc-save-offset)))
;; Handle the register arg cases.
ZERO-VALUES
- (inst mov ebx rbp-tn)
+ (inst lea ebx (make-ea :qword :base rbp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(inst mov edx nil-value)
(inst mov edi edx)
(inst mov esi edx)
- (inst lea rsp-tn
- (make-ea :qword :base ebx
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov rsp-tn rbp-tn)
(inst stc)
(inst pop rbp-tn)
(inst ret)
;; check for this case when size > speed.
ONE-VALUE
(loadw edx esi -1)
- (inst lea rsp-tn
- (make-ea :qword :base rbp-tn
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov rsp-tn rbp-tn)
(inst clc)
(inst pop rbp-tn)
(inst ret)
TWO-VALUES
- (inst mov ebx rbp-tn)
+ (inst lea ebx (make-ea :qword :base rbp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(loadw edx esi -1)
(loadw edi esi -2)
(inst mov esi nil-value)
- (inst lea rsp-tn
- (make-ea :qword :base ebx
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov rsp-tn rbp-tn)
(inst stc)
(inst pop rbp-tn)
(inst ret)
THREE-VALUES
- (inst mov ebx rbp-tn)
+ (inst lea ebx (make-ea :qword :base rbp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(loadw edx esi -1)
(loadw edi esi -2)
(loadw esi esi -3)
- (inst lea rsp-tn
- (make-ea :qword :base ebx
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov rsp-tn rbp-tn)
(inst stc)
(inst pop rbp-tn)
(inst ret))
;; Clear most of the stack.
(inst lea rsp-tn
- (make-ea :qword :base rbp-tn :disp (* -3 n-word-bytes)))
+ (make-ea :qword :base rbp-tn :disp (* (- sp->fp-offset 3) n-word-bytes)))
;; Push the return-pc so it looks like we just called.
(pushw rbp-tn (frame-word-offset return-pc-save-offset))
(inst ret)
DO-STATIC-FUN
+ ;; Same as: (inst enter (fixnumize 1))
(inst push ebp-tn)
- (inst lea ebp-tn (make-ea :dword
- :base esp-tn
- :disp (* 2 n-word-bytes)))
+ (inst mov ebp-tn esp-tn)
(inst sub esp-tn (fixnumize 1))
- (inst push (make-ea :dword :base ebp-tn :disp (- n-word-bytes)))
+ (inst push (make-ea :dword :base ebp-tn
+ :disp (frame-byte-offset return-pc-save-offset)))
(inst mov ecx (fixnumize 2)) ; arg count
(inst jmp
(make-ea :dword
(inst jmp :z FIXNUM)
(inst push ebp-tn)
- (inst lea ebp-tn (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes)))
+ (inst mov ebp-tn esp-tn)
(inst sub esp-tn (fixnumize 1))
- (inst push (make-ea :dword :base ebp-tn :disp (- n-word-bytes)))
+ (inst push (make-ea :dword :base ebp-tn
+ :disp (frame-byte-offset return-pc-save-offset)))
(inst mov ecx (fixnumize 1)) ; arg count
(inst jmp (make-ea :dword
:disp (+ nil-value (static-fun-offset '%negate))))
(inst ret)
DO-STATIC-FUN
- (move ecx esp-tn)
(inst sub esp-tn (fixnumize 3))
- (inst mov (make-ea :dword
- :base ecx
- :disp (frame-byte-offset ocfp-save-offset))
+ (inst mov (make-ea :dword :base esp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))
ebp-tn)
- (move ebp-tn ecx)
+ (inst lea ebp-tn (make-ea :dword :base esp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset))))
(inst mov ecx (fixnumize 2))
(inst call (make-ea :dword
:disp (+ nil-value
(inst cmp ecx other-pointer-lowtag)
(inst jmp :e DO-STATIC-FUN)
- ;; Not both other pointers
+ ;; At least one fixnum
(inst cmp x y)
RET
(inst ret)
(inst cmp x y)
(inst jmp :e RET)
- (move ecx esp-tn)
(inst sub esp-tn (fixnumize 3))
- (inst mov (make-ea :dword
- :base ecx
- :disp (frame-byte-offset ocfp-save-offset))
+ (inst mov (make-ea :dword :base esp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))
ebp-tn)
- (move ebp-tn ecx)
+ (inst lea ebp-tn (make-ea :dword :base esp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset))))
(inst mov ecx (fixnumize 2))
(inst call (make-ea :dword
:disp (+ nil-value (static-fun-offset 'eql))))
(inst ret)
DO-STATIC-FUN
- (move ecx esp-tn)
(inst sub esp-tn (fixnumize 3))
- (inst mov (make-ea :dword
- :base ecx
- :disp (frame-byte-offset ocfp-save-offset))
+ (inst mov (make-ea :dword :base esp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))
ebp-tn)
- (move ebp-tn ecx)
+ (inst lea ebp-tn (make-ea :dword :base esp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset))))
(inst mov ecx (fixnumize 2))
(inst call (make-ea :dword
:disp (+ nil-value (static-fun-offset 'two-arg-=))))
(inst cmp ecx (fixnumize 3))
(inst jmp :e THREE-VALUES)
- (inst mov ebx ebp-tn)
- ;; Save the count, because the loop is going to destroy it.
+ ;; As per the calling convention EBX is expected to point at the SP
+ ;; before the stack frame.
+ (inst lea ebx (make-ea :dword :base ebp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
+
+ ;; Save the count, the return address and restore the frame pointer,
+ ;; because the loop is going to destroy them.
(inst mov edx ecx)
(inst mov eax (make-ea :dword :base ebp-tn
:disp (frame-byte-offset return-pc-save-offset)))
;; Handle the register arg cases.
ZERO-VALUES
- (inst mov ebx ebp-tn)
+ (inst lea ebx (make-ea :dword :base ebp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(inst mov edx nil-value)
(inst mov edi edx)
(inst mov esi edx)
- (inst lea esp-tn
- (make-ea :dword :base ebx
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov esp-tn ebp-tn)
(inst stc)
(inst pop ebp-tn)
(inst ret)
;; check for this case when size > speed.
ONE-VALUE
(loadw edx esi -1)
- (inst lea esp-tn
- (make-ea :dword :base ebp-tn
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov esp-tn ebp-tn)
(inst clc)
(inst pop ebp-tn)
(inst ret)
TWO-VALUES
- (inst mov ebx ebp-tn)
+ (inst lea ebx (make-ea :dword :base ebp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(loadw edx esi -1)
(loadw edi esi -2)
(inst mov esi nil-value)
- (inst lea esp-tn
- (make-ea :dword :base ebx
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov esp-tn ebp-tn)
(inst stc)
(inst pop ebp-tn)
(inst ret)
THREE-VALUES
- (inst mov ebx ebp-tn)
+ (inst lea ebx (make-ea :dword :base ebp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(loadw edx esi -1)
(loadw edi esi -2)
(loadw esi esi -3)
- (inst lea esp-tn
- (make-ea :dword :base ebx
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov esp-tn ebp-tn)
(inst stc)
(inst pop ebp-tn)
(inst ret))
;; Clear most of the stack.
(inst lea esp-tn
- (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes)))
+ (make-ea :dword :base ebp-tn :disp (* (- sp->fp-offset 3) n-word-bytes)))
;; Push the return-pc so it looks like we just called.
(pushw ebp-tn (frame-word-offset return-pc-save-offset))
(- (get-lisp-obj-address code)
sb!vm:other-pointer-lowtag)
code-header-len)))
-; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
+ ;;(format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
(values pc-offset code)))))
#!+(or x86 x86-64)
(declaim (maybe-inline x86-call-context))
(defun x86-call-context (fp)
(declare (type system-area-pointer fp))
- (labels ((fail ()
- (values nil
- (int-sap 0)
- (int-sap 0)))
- (handle (fp)
- (cond
- ((not (control-stack-pointer-valid-p fp))
- (fail))
- (t
- ;; Check the two possible frame pointers.
- (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset)
- sb!vm::n-word-bytes))))
- (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
- sb!vm::n-word-bytes))))
- (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
- (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
- (cond ((and (sap> lisp-ocfp fp)
- (control-stack-pointer-valid-p lisp-ocfp)
- (ra-pointer-valid-p lisp-ra)
- (sap> c-ocfp fp)
- (control-stack-pointer-valid-p c-ocfp)
- (ra-pointer-valid-p c-ra))
- ;; Look forward another step to check their validity.
- (let ((lisp-ok (handle lisp-ocfp))
- (c-ok (handle c-ocfp)))
- (cond ((and lisp-ok c-ok)
- ;; Both still seem valid - choose the lisp frame.
- #!+freebsd
- (if (sap> lisp-ocfp c-ocfp)
- (values t lisp-ra lisp-ocfp)
- (values t c-ra c-ocfp))
- #!-freebsd
- (values t lisp-ra lisp-ocfp))
- (lisp-ok
- ;; The lisp convention is looking good.
- (values t lisp-ra lisp-ocfp))
- (c-ok
- ;; The C convention is looking good.
- (values t c-ra c-ocfp))
- (t
- ;; Neither seems right?
- (fail)))))
- ((and (sap> lisp-ocfp fp)
- (control-stack-pointer-valid-p lisp-ocfp)
- (ra-pointer-valid-p lisp-ra))
- ;; The lisp convention is looking good.
- (values t lisp-ra lisp-ocfp))
- ((and (sap> c-ocfp fp)
- (control-stack-pointer-valid-p c-ocfp)
- #!-linux (ra-pointer-valid-p c-ra))
- ;; The C convention is looking good.
- (values t c-ra c-ocfp))
- (t
- (fail))))))))
- (handle fp)))
+ (let ((ocfp (sap-ref-sap fp (sb!vm::frame-byte-offset ocfp-save-offset)))
+ (ra (sap-ref-sap fp (sb!vm::frame-byte-offset return-pc-save-offset))))
+ (if (and (control-stack-pointer-valid-p fp)
+ (sap> ocfp fp)
+ (control-stack-pointer-valid-p ocfp)
+ (ra-pointer-valid-p ra))
+ (values t ra ocfp)
+ (values nil (int-sap 0) (int-sap 0)))))
) ; #+x86 PROGN
\f
(#.ocfp-save-offset
(stack-ref pointer stack-slot))
(#.lra-save-offset
- (sap-ref-sap pointer (- (* (1+ stack-slot)
- sb!vm::n-word-bytes))))))))
+ (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot)))))))
(defun (setf get-context-value) (value frame stack-slot loc)
(declare (type compiled-frame frame) (type unsigned-byte stack-slot)
(#.ocfp-save-offset
(setf (stack-ref pointer stack-slot) value))
(#.lra-save-offset
- (setf (sap-ref-sap pointer (- (* (1+ stack-slot)
- sb!vm::n-word-bytes))) value))))))
+ (setf (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot))
+ value))))))
(defun foreign-function-backtrace-name (sap)
(let ((name (sap-foreign-symbol sap)))
,@body))
(stack-frame-offset (data-width offset)
#!+(or x86 x86-64)
- `(- (* (+ (sb!c:sc-offset-offset sc-offset) ,data-width ,offset)
- sb!vm:n-word-bytes))
+ `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset)
+ (1- ,data-width)
+ ,offset))
#!-(or x86 x86-64)
(declare (ignore data-width))
#!-(or x86 x86-64)
,@body))
(stack-frame-offset (data-width offset)
#!+(or x86 x86-64)
- `(- (* (+ (sb!c:sc-offset-offset sc-offset) ,data-width ,offset)
- sb!vm:n-word-bytes))
+ `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset)
+ (1- ,data-width)
+ ,offset))
#!-(or x86 x86-64)
(declare (ignore data-width))
#!-(or x86 x86-64)
(inst lea rsp-tn
(make-ea :qword :base rbp-tn
:disp (- (* n-word-bytes
- (max 3 (sb-allocated-size 'stack)))))))
+ (- (max 3 (sb-allocated-size 'stack))
+ sp->fp-offset))))))
(trace-table-entry trace-table-normal)))
;;; or a multiple-call-local. All it does is allocate stack space for the
;;; callee (who has the same size stack as us).
(define-vop (allocate-frame)
- (:results (res :scs (any-reg control-stack))
+ (:results (res :scs (any-reg))
(nfp))
(:info callee)
(:ignore nfp callee)
(:generator 2
- (move res rsp-tn)
+ (inst lea res (make-ea :qword :base rsp-tn
+ :disp (- (* sp->fp-offset n-word-bytes))))
(inst sub rsp-tn (* n-word-bytes (sb-allocated-size 'stack)))))
;;; Allocate a partial frame for passing stack arguments in a full
;;; before it can extend the stack.
(define-vop (allocate-full-call-frame)
(:info nargs)
- (:results (res :scs (any-reg control-stack)))
+ (:results (res :scs (any-reg)))
(:generator 2
- (move res rsp-tn)
+ (inst lea res (make-ea :qword :base rsp-tn
+ :disp (- (* sp->fp-offset n-word-bytes))))
(inst sub rsp-tn (* (max nargs 3) n-word-bytes))))
\f
;;; Emit code needed at the return-point from an unknown-values call
(when first-stack-arg-p
;; There are stack args so the frame of the callee is
;; still there, save RDX in its first slot temporalily.
- (storew rdx-tn rbx-tn -1))
- (loadw rdx-tn rbx-tn (frame-word-offset i))
+ (storew rdx-tn rbx-tn (frame-word-offset sp->fp-offset)))
+ (loadw rdx-tn rbx-tn (frame-word-offset (+ sp->fp-offset i)))
(inst mov tn rdx-tn)))
(emit-label defaulting-done)
- (loadw rdx-tn rbx-tn -1)
+ (loadw rdx-tn rbx-tn (frame-word-offset sp->fp-offset))
(move rsp-tn rbx-tn)
(let ((defaults (defaults)))
;; and then default the remaining stack arguments.
(emit-label regs-defaulted)
;; Save EDI.
- (storew rdi-tn rbx-tn (frame-word-offset 1))
+ (storew rdi-tn rbx-tn (frame-word-offset (+ sp->fp-offset 1)))
;; Compute the number of stack arguments, and if it's zero or
;; less, don't copy any stack arguments.
(inst sub rcx-tn (fixnumize register-arg-count))
(make-ea :qword :base rbp-tn
:disp (frame-byte-offset register-arg-count)))
;; Save ESI, and compute a pointer to where the args come from.
- (storew rsi-tn rbx-tn (frame-word-offset 2))
+ (storew rsi-tn rbx-tn (frame-word-offset (+ sp->fp-offset 2)))
(inst lea rsi-tn
(make-ea :qword :base rbx-tn
- :disp (frame-byte-offset register-arg-count)))
+ :disp (frame-byte-offset
+ (+ sp->fp-offset register-arg-count))))
;; Do the copy.
(inst shr rcx-tn word-shift) ; make word count
(inst std)
(inst rep)
(inst movs :qword)
;; Restore RSI.
- (loadw rsi-tn rbx-tn (frame-word-offset 2))
+ (loadw rsi-tn rbx-tn (frame-word-offset (+ sp->fp-offset 2)))
;; Now we have to default the remaining args. Find out how many.
(inst sub rax-tn (fixnumize (- nvals register-arg-count)))
(inst neg rax-tn)
(inst stos rax-tn)
;; Restore EDI, and reset the stack.
(emit-label restore-edi)
- (loadw rdi-tn rbx-tn (frame-word-offset 1))
+ (loadw rdi-tn rbx-tn (frame-word-offset (+ sp->fp-offset 1)))
(inst mov rsp-tn rbx-tn)
(inst cld))))
(values))
(check-ocfp-and-return-pc old-fp return-pc)
(trace-table-entry trace-table-fun-epilogue)
;; Zot all of the stack except for the old-fp and return-pc.
- (inst lea rsp-tn
- (make-ea :qword :base rbp-tn
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov rsp-tn rbp-tn)
(inst pop rbp-tn)
(inst ret)
(trace-table-entry trace-table-normal)))
,(if variable
'(inst sub rsp-tn (fixnumize 3)))
+ ;; Bias the new-fp for use as an fp
+ ,(if variable
+ '(inst sub new-fp (fixnumize sp->fp-offset)))
+
;; Save the fp
(storew rbp-tn new-fp
(frame-word-offset ocfp-save-offset))
(check-ocfp-and-return-pc old-fp return-pc)
(trace-table-entry trace-table-fun-epilogue)
;; Drop stack above old-fp
- (inst lea rsp-tn (make-ea :qword :base rbp-tn
- :disp (frame-byte-offset (tn-offset old-fp))))
+ (inst mov rsp-tn rbp-tn)
;; Clear the multiple-value return flag
(inst clc)
;; Restore the old frame pointer
(error "nvalues is 1"))
(trace-table-entry trace-table-fun-epilogue)
;; Establish the values pointer and values count.
- (move rbx rbp-tn)
+ (inst lea rbx (make-ea :qword :base rbp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(if (zerop nvals)
(zeroize rcx) ; smaller
(inst mov rcx (fixnumize nvals)))
- ;; Clear as much of the stack as possible, but not past the old
- ;; frame address.
- (inst lea rsp-tn
- (make-ea :qword :base rbx
- :disp (frame-byte-offset
- (if (< register-arg-count nvals)
- (1- nvals)
- ocfp-save-offset))))
;; Pre-default any argument register that need it.
(when (< nvals register-arg-count)
(let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
;; stack and we've changed the stack pointer. So we have to
;; tell it to index off of RBX instead of RBP.
(cond ((<= nvals register-arg-count)
+ (inst mov rsp-tn rbp-tn)
(inst pop rbp-tn)
(inst ret))
(t
;; Some values are on the stack after RETURN-PC and OLD-FP,
;; can't return normally and some slots of the frame will
;; be used as temporaries by the receiver.
+ ;;
+ ;; Clear as much of the stack as possible, but not past the
+ ;; old frame address.
+ (inst lea rsp-tn
+ (make-ea :qword :base rbp-tn
+ :disp (frame-byte-offset (1- nvals))))
(move rbp-tn old-fp)
(inst push (make-ea :qword :base rbx
- :disp (frame-byte-offset (tn-offset return-pc))))
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ (tn-offset return-pc)))))
(inst ret)))
(trace-table-entry trace-table-normal)))
;;; assembly-routine.
;;;
;;; The assembly routine takes the following args:
-;;; RAX -- the return-pc to finally jump to.
-;;; RBX -- pointer to where to put the values.
;;; RCX -- number of values to find there.
;;; RSI -- pointer to where to find the values.
(define-vop (return-multiple)
(inst jmp :ne not-single)
;; Return with one value.
(loadw a0 vals -1)
- (inst lea rsp-tn (make-ea :qword :base rbp-tn
- :disp (frame-byte-offset ocfp-save-offset)))
+ ;; Clear the stack until ocfp.
+ (inst mov rsp-tn rbp-tn)
;; clear the multiple-value return flag
(inst clc)
;; Out of here.
(inst jmp :be JUST-ALLOC-FRAME)))
;; Allocate the space on the stack.
- ;; stack = rbp - (max 3 frame-size) - (nargs - fixed)
+ ;; stack = rbp + sp->fp-offset - (max 3 frame-size) - (nargs - fixed)
(inst lea rbx-tn
(make-ea :qword :base rbp-tn
- :disp (- (fixnumize fixed)
- (* n-word-bytes
+ :disp (* n-word-bytes
+ (- (+ sp->fp-offset fixed)
(max 3 (sb-allocated-size 'stack))))))
(inst sub rbx-tn rcx-tn) ; Got the new stack in rbx
(inst mov rsp-tn rbx-tn)
(inst sub rcx-tn (fixnumize fixed))))
;; Initialize R8 to be the end of args.
- (inst mov source rbp-tn)
+ (inst lea source (make-ea :qword :base rbp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(inst sub source rbx-tn)
;; We need to copy from downwards up to avoid overwriting some of
( nil )
;; Store it relative to rbp
(inst mov (make-ea :qword :base rbp-tn
- :disp (- (* n-word-bytes
- (+ 1 (- i fixed)
- (max 3 (sb-allocated-size 'stack))))))
+ :disp (* n-word-bytes
+ (- sp->fp-offset
+ (+ 1
+ (- i fixed)
+ (max 3 (sb-allocated-size
+ 'stack))))))
(nth i *register-arg-tns*))
(incf i)
JUST-ALLOC-FRAME
(inst lea rsp-tn
(make-ea :qword :base rbp-tn
- :disp (- (* n-word-bytes
+ :disp (* n-word-bytes
+ (- sp->fp-offset
(max 3 (sb-allocated-size 'stack))))))
DONE))
(character-stack
#!-sb-unicode
(inst mov
- ;; FIXME: naked 8 (should be... what? n-register-bytes?
- ;; n-word-bytes? Dunno.
- (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 8)))
+ ;; 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 (tn-offset y)) ; c-call
+ (storew x fp (frame-word-offset (tn-offset y))))))))
(define-move-vop move-character-arg :move-arg
(any-reg character-reg) (character-reg))
(move temp offset)
(inst neg temp)
(inst mov result
- (make-ea :qword :base sap :disp (- n-word-bytes) :index temp))))
+ (make-ea :qword :base sap :disp (frame-byte-offset 0) :index temp))))
(define-vop (read-control-stack-c)
(:translate stack-ref)
(:result-types *)
(:generator 5
(inst mov result (make-ea :qword :base sap
- :disp (- (* (1+ index) n-word-bytes))))))
+ :disp (frame-byte-offset index)))))
(define-vop (write-control-stack)
(:translate %set-stack-ref)
(move temp offset)
(inst neg temp)
(inst mov
- (make-ea :qword :base sap :disp (- n-word-bytes) :index temp) value)
+ (make-ea :qword :base sap :disp (frame-byte-offset 0) :index temp)
+ value)
(move result value)))
(define-vop (write-control-stack-c)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 5
- (inst mov (make-ea :qword :base sap
- :disp (- (* (1+ index) n-word-bytes)))
+ (inst mov (make-ea :qword :base sap :disp (frame-byte-offset index))
value)
(move result value)))
(declare (ignore kind))
`(make-ea
:qword :base rbp-tn
- :disp (- (* (+ (tn-offset ,tn) 1)
- n-word-bytes)))))
+ :disp (frame-byte-offset (tn-offset ,tn)))))
(defun ea-for-sf-stack (tn)
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack (tn)
(declare (ignore kind))
`(make-ea
:qword :base ,base
- :disp (- (* (+ (tn-offset ,tn)
- (* 1 (ecase ,slot (:real 1) (:imag 2))))
- n-word-bytes)))))
+ :disp (frame-byte-offset
+ (+ (tn-offset ,tn)
+ (cond ((= (tn-offset ,base) rsp-offset)
+ sp->fp-offset)
+ ((= (tn-offset ,base) rbp-offset)
+ 0)
+ (t (error "Unexpected offset.")))
+ (ecase ,slot (:real 0) (:imag 1)))))))
(defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
(ea-for-cxf-stack tn :single :real base))
(defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
(:double '((inst movsd ea x)))))
(let ((ea (make-ea
:dword :base fp
- :disp (- (* (1+ (tn-offset y))
- n-word-bytes)))))
+ :disp (frame-byte-offset (tn-offset y)))))
,@(ecase format
(:single '((inst movss ea x)))
(:double '((inst movsd ea x))))))))))
(inst movsd temp float)
(move hi-bits 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 double-float-value-slot
other-pointer-lowtag)))
(inst movsd temp float)
(move lo-bits temp))
(double-stack
- (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
+ (loadw lo-bits ebp-tn (frame-word-offset (tn-offset float))))
(descriptor-reg
(loadw lo-bits float double-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 RBP.
- (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))
;; Lisp stack
(etypecase val
(integer
- (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
+ (storew (fixnumize val) fp (frame-word-offset (tn-offset y))))
(symbol
(storew (+ nil-value (static-symbol-offset val))
- fp (- (1+ (tn-offset y)))))
+ fp (frame-word-offset (tn-offset y))))
(character
(storew (logior (ash (char-code val) n-widetag-bits)
character-widetag)
- fp (- (1+ (tn-offset y))))))))
+ fp (frame-word-offset (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))))))))))
+ (storew x fp (frame-word-offset (tn-offset y)))))))))
(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 :qword :base rbp-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.
(storew rdx-tn rbx-tn -1))
(sc-case tn
((descriptor-reg any-reg)
- (loadw tn start (frame-word-offset i)))
+ (loadw tn start (frame-word-offset (+ sp->fp-offset i))))
((control-stack)
- (loadw move-temp start (frame-word-offset i))
+ (loadw move-temp start
+ (frame-word-offset (+ sp->fp-offset i)))
(inst mov tn move-temp)))))
(let ((defaulting-done (gen-label)))
(emit-label defaulting-done)
;; Clear the stack
(inst lea rsp-tn
- (make-ea :qword :base rbp-tn :disp (* -3 n-word-bytes)))
+ (make-ea :qword :base rbp-tn
+ :disp (* (- sp->fp-offset 3) n-word-bytes)))
;; Push the return-pc so it looks like we just called.
(pushw rbp-tn (frame-word-offset return-pc-save-offset))
(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))
(:policy :safe)
(:variant-vars function)
(:vop-var vop)
- ;;(:node-var node)
- (:temporary (:sc unsigned-reg :offset ebx-offset
- :from (:eval 0) :to (:eval 2)) ebx)
(:temporary (:sc unsigned-reg :offset ecx-offset
:from (:eval 0) :to (:eval 2)) ecx))
(<= num-results register-arg-count))
(error "either too many args (~W) or too many results (~W); max = ~W"
num-args num-results register-arg-count))
- (let ((num-temps (max num-args num-results)))
+ (let ((num-temps (max num-args num-results))
+ (node (gensym "NODE-")))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(dotimes (i num-results)
(let ((result-name (intern (format nil "RESULT-~D" i))))
,@(temps)
(:temporary (:sc unsigned-reg) call-target)
(:results ,@(results))
+ (:node-var ,node)
(:generator ,(+ 50 num-args num-results)
,@(moves (temp-names) (arg-names))
- ;; If speed not more important than size, duplicate the
+ ;; If speed is at least as important as size, duplicate the
;; effect of the ENTER with discrete instructions. Takes
- ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
- (cond (t ;(policy node (>= speed space))
- (inst mov ebx rsp-tn)
- ;; Dummy for return address
+ ;; 3+4+4=11 bytes as opposed to 1+4=5 bytes.
+ (cond ((policy ,node (>= speed space))
+ (inst sub rsp-tn (fixnumize 3))
+ (inst mov (make-ea :qword :base rsp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))
+ rbp-tn)
+ (inst lea rbp-tn (make-ea :qword :base rsp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))))
+ (t
+ ;; Dummy for return address.
(inst push rbp-tn)
- ;; Save the old-fp
- (inst push rbp-tn)
- ;; Ensure that at least three slots are available; one
- ;; above, two more needed.
- (inst sub rsp-tn (fixnumize 1))
- (inst mov rbp-tn ebx))
- #+(or) (t
- (inst enter (fixnumize 2))
- ;; The enter instruction pushes EBP and then copies
- ;; ESP into EBP. We want the new EBP to be the
- ;; original ESP, so we fix it up afterwards.
- (inst add rbp-tn (fixnumize 1))))
+ (inst enter (fixnumize 1))))
,(if (zerop num-args)
'(inst xor ecx ecx)
(make-byte-tn value))
((sc-is value control-stack)
(make-ea :byte :base rbp-tn
- :disp (- (* (1+ (tn-offset value)) n-word-bytes))))
+ :disp (frame-byte-offset (tn-offset value))))
(t
value))
sb!vm::fixnum-tag-mask))
\f
;;;; miscellaneous function call parameters
-;;; offsets of special stack frame locations
-(def!constant ocfp-save-offset 1)
+;;; Offsets of special stack frame locations relative to RBP.
+;;;
+;;; Consider the standard prologue PUSH RBP; MOV RBP, RSP: the return
+;;; address is at RBP+8, the old control stack frame pointer is at
+;;; RBP, the magic 3rd slot is at RBP-8. Then come the locals from
+;;; RBP-16 on.
(def!constant return-pc-save-offset 0)
+(def!constant ocfp-save-offset 1)
(def!constant code-save-offset 2)
+;;; Let SP be the stack pointer before CALLing, and FP is the frame
+;;; pointer after the standard prologue. SP +
+;;; FRAME-WORD-OFFSET(SP->FP-OFFSET + I) = FP + FRAME-WORD-OFFSET(I).
+(def!constant sp->fp-offset 2)
(declaim (inline frame-word-offset))
(defun frame-word-offset (index)
- (- (1+ index)))
+ (- (1- index)))
(declaim (inline frame-byte-offset))
(defun frame-byte-offset (index)
(inst lea esp-tn
(make-ea :dword :base ebp-tn
:disp (- (* n-word-bytes
- (max 3 (sb-allocated-size 'stack)))))))
+ (- (max 3 (sb-allocated-size 'stack))
+ sp->fp-offset))))))
(trace-table-entry trace-table-normal)))
;;; or a multiple-call-local. All it does is allocate stack space for the
;;; callee (who has the same size stack as us).
(define-vop (allocate-frame)
- (:results (res :scs (any-reg control-stack))
+ (:results (res :scs (any-reg))
(nfp))
(:info callee)
(:ignore nfp callee)
(:generator 2
- (move res esp-tn)
+ (inst lea res (make-ea :dword :base esp-tn
+ :disp (- (* sp->fp-offset n-word-bytes))))
(inst sub esp-tn (* n-word-bytes (sb-allocated-size 'stack)))))
;;; Allocate a partial frame for passing stack arguments in a full
;;; before it can extend the stack.
(define-vop (allocate-full-call-frame)
(:info nargs)
- (:results (res :scs (any-reg control-stack)))
+ (:results (res :scs (any-reg)))
(:generator 2
- (move res esp-tn)
+ (inst lea res (make-ea :dword :base esp-tn
+ :disp (- (* sp->fp-offset n-word-bytes))))
(inst sub esp-tn (* (max nargs 3) n-word-bytes))))
\f
;;; Emit code needed at the return-point from an unknown-values call
(when first-stack-arg-p
;; There are stack args so the frame of the callee is
;; still there, save EDX in its first slot temporalily.
- (storew edx-tn ebx-tn -1))
- (loadw edx-tn ebx-tn (frame-word-offset i))
+ (storew edx-tn ebx-tn (frame-word-offset sp->fp-offset)))
+ (loadw edx-tn ebx-tn (frame-word-offset (+ sp->fp-offset i)))
(inst mov tn edx-tn)))
(emit-label defaulting-done)
- (loadw edx-tn ebx-tn -1)
+ (loadw edx-tn ebx-tn (frame-word-offset sp->fp-offset))
(move esp-tn ebx-tn)
(let ((defaults (defaults)))
;; and then default the remaining stack arguments.
(emit-label regs-defaulted)
;; Save EDI.
- (storew edi-tn ebx-tn (frame-word-offset 1))
+ (storew edi-tn ebx-tn (frame-word-offset (+ sp->fp-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))
(make-ea :dword :base ebp-tn
:disp (frame-byte-offset register-arg-count)))
;; Save ESI, and compute a pointer to where the args come from.
- (storew esi-tn ebx-tn (frame-word-offset 2))
+ (storew esi-tn ebx-tn (frame-word-offset (+ sp->fp-offset 2)))
(inst lea esi-tn
(make-ea :dword :base ebx-tn
- :disp (frame-byte-offset register-arg-count)))
+ :disp (frame-byte-offset
+ (+ sp->fp-offset register-arg-count))))
;; Do the copy.
(inst shr ecx-tn word-shift) ; make word count
(inst std)
(inst rep)
(inst movs :dword)
;; Restore ESI.
- (loadw esi-tn ebx-tn (frame-word-offset 2))
+ (loadw esi-tn ebx-tn (frame-word-offset (+ sp->fp-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)
(inst stos eax-tn)
;; Restore EDI, and reset the stack.
(emit-label restore-edi)
- (loadw edi-tn ebx-tn (frame-word-offset 1))
+ (loadw edi-tn ebx-tn (frame-word-offset (+ sp->fp-offset 1)))
(inst mov esp-tn ebx-tn)
(inst cld))))
(values))
(check-ocfp-and-return-pc old-fp return-pc)
(trace-table-entry trace-table-fun-epilogue)
;; Zot all of the stack except for the old-fp and return-pc.
- (inst lea esp-tn
- (make-ea :dword :base ebp-tn
- :disp (frame-byte-offset ocfp-save-offset)))
+ (inst mov esp-tn ebp-tn)
(inst pop ebp-tn)
(inst ret)
(trace-table-entry trace-table-normal)))
,(if variable
'(inst sub esp-tn (fixnumize 3)))
+ ;; Bias the new-fp for use as an fp
+ ,(if variable
+ '(inst sub new-fp (fixnumize sp->fp-offset)))
+
;; Save the fp
(storew ebp-tn new-fp
(frame-word-offset ocfp-save-offset))
(check-ocfp-and-return-pc old-fp return-pc)
(trace-table-entry trace-table-fun-epilogue)
;; Drop stack above old-fp
- (inst lea esp-tn (make-ea :dword :base ebp-tn
- :disp (frame-byte-offset (tn-offset old-fp))))
+ (inst mov esp-tn ebp-tn)
;; Clear the multiple-value return flag
(inst clc)
;; Restore the old frame pointer
(error "nvalues is 1"))
(trace-table-entry trace-table-fun-epilogue)
;; Establish the values pointer and values count.
- (move ebx ebp-tn)
+ (inst lea ebx (make-ea :dword :base ebp-tn
+ :disp (* sp->fp-offset n-word-bytes)))
(if (zerop nvals)
(inst xor ecx ecx) ; smaller
(inst mov ecx (fixnumize nvals)))
- ;; Clear as much of the stack as possible, but not past the old
- ;; frame address.
- (inst lea esp-tn
- (make-ea :dword :base ebx
- :disp (frame-byte-offset
- (if (< register-arg-count nvals)
- (1- nvals)
- ocfp-save-offset))))
;; Pre-default any argument register that need it.
(when (< nvals register-arg-count)
(let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
;; stack and we've changed the stack pointer. So we have to
;; tell it to index off of EBX instead of EBP.
(cond ((<= nvals register-arg-count)
+ (inst mov esp-tn ebp-tn)
(inst pop ebp-tn)
(inst ret))
(t
;; Some values are on the stack after RETURN-PC and OLD-FP,
;; can't return normally and some slots of the frame will
;; be used as temporaries by the receiver.
+ ;;
+ ;; Clear as much of the stack as possible, but not past the
+ ;; old frame address.
+ (inst lea esp-tn
+ (make-ea :dword :base ebp-tn
+ :disp (frame-byte-offset (1- nvals))))
(move ebp-tn old-fp)
(inst push (make-ea :dword :base ebx
- :disp (frame-byte-offset (tn-offset return-pc))))
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ (tn-offset return-pc)))))
(inst ret)))
(trace-table-entry trace-table-normal)))
;;; assembly-routine.
;;;
;;; The assembly routine takes the following args:
-;;; EAX -- the return-pc to finally jump to.
-;;; EBX -- pointer to where to put the values.
;;; ECX -- number of values to find there.
;;; ESI -- pointer to where to find the values.
(define-vop (return-multiple)
(inst jmp :ne not-single)
;; Return with one value.
(loadw a0 vals -1)
- (inst lea esp-tn (make-ea :dword :base ebp-tn
- :disp (frame-byte-offset ocfp-save-offset)))
+ ;; Clear the stack until ocfp.
+ (inst mov esp-tn ebp-tn)
;; clear the multiple-value return flag
(inst clc)
;; Out of here.
(inst jmp :be JUST-ALLOC-FRAME)))
;; Allocate the space on the stack.
- ;; stack = ebp - (max 3 frame-size) - (nargs - fixed)
+ ;; stack = ebp + sp->fp-offset - (max 3 frame-size) - (nargs - fixed)
(inst lea ebx-tn
(make-ea :dword :base ebp-tn
- :disp (- (fixnumize fixed)
- (* n-word-bytes
+ :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
(inst mov esp-tn ebx-tn)
;; now.
;; Initialize src to be end of args.
- (inst mov esi-tn ebp-tn)
+ (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
;; Here: nargs>=1 && nargs>fixed
(when (< fixed register-arg-count)
- ;; Now we have to deposit any more args that showed up in
- ;; registers.
- (do ((i fixed))
- ( nil )
- ;; Store it relative to ebp
- (inst mov (make-ea :dword :base ebp-tn
- :disp (- (* n-word-bytes
- (+ 1 (- i fixed)
- (max 3 (sb-allocated-size 'stack))))))
- (nth i *register-arg-tns*))
-
- (incf i)
- (when (>= i register-arg-count)
- (return))
-
- ;; Don't deposit any more than there are.
- (if (zerop i)
- (inst test ecx-tn ecx-tn)
- (inst cmp ecx-tn (fixnumize i)))
- (inst jmp :eq DONE)))
+ ;; Now we have to deposit any more args that showed up in
+ ;; registers.
+ (do ((i fixed))
+ ( nil )
+ ;; Store it relative to ebp
+ (inst mov (make-ea :dword :base ebp-tn
+ :disp (* n-word-bytes
+ (- sp->fp-offset
+ (+ 1
+ (- i fixed)
+ (max 3 (sb-allocated-size
+ 'stack))))))
+ (nth i *register-arg-tns*))
+
+ (incf i)
+ (when (>= i register-arg-count)
+ (return))
+
+ ;; Don't deposit any more than there are.
+ (if (zerop i)
+ (inst test ecx-tn ecx-tn)
+ (inst cmp ecx-tn (fixnumize i)))
+ (inst jmp :eq DONE)))
(inst jmp DONE)
JUST-ALLOC-FRAME
(inst lea esp-tn
(make-ea :dword :base ebp-tn
- :disp (- (* n-word-bytes
+ :disp (* n-word-bytes
+ (- sp->fp-offset
(max 3 (sb-allocated-size 'stack))))))
DONE))
(move temp offset)
(inst neg temp)
(inst mov
- (make-ea :dword :base sap :disp (frame-byte-offset 0) :index temp) value)
+ (make-ea :dword :base sap :disp (frame-byte-offset 0) :index temp)
+ value)
(move result value)))
(define-vop (write-control-stack-c)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 5
- (inst mov (make-ea :dword :base sap
- :disp (frame-byte-offset index))
+ (inst mov (make-ea :dword :base sap :disp (frame-byte-offset index))
value)
(move result value)))
(storew edx-tn ebx-tn -1))
(sc-case tn
((descriptor-reg any-reg)
- (loadw tn start (frame-word-offset i)))
+ (loadw tn start (frame-word-offset (+ sp->fp-offset i))))
((control-stack)
- (loadw move-temp start (frame-word-offset i))
+ (loadw move-temp start
+ (frame-word-offset (+ sp->fp-offset i)))
(inst mov tn move-temp)))))
(let ((defaulting-done (gen-label)))
(emit-label defaulting-done)
;; Clear the stack
(inst lea esp-tn
- (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes)))
+ (make-ea :dword :base ebp-tn
+ :disp (* (- sp->fp-offset 3) n-word-bytes)))
;; Push the return-pc so it looks like we just called.
(pushw ebp-tn (frame-word-offset return-pc-save-offset))
(:policy :safe)
(:variant-vars function)
(:vop-var vop)
- ;;(:node-var node)
- (:temporary (:sc unsigned-reg :offset ebx-offset
- :from (:eval 0) :to (:eval 2)) ebx)
(:temporary (:sc unsigned-reg :offset ecx-offset
:from (:eval 0) :to (:eval 2)) ecx))
(<= num-results register-arg-count))
(error "either too many args (~W) or too many results (~W); max = ~W"
num-args num-results register-arg-count))
- (let ((num-temps (max num-args num-results)))
+ (let ((num-temps (max num-args num-results))
+ (node (gensym "NODE-")))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(dotimes (i num-results)
(let ((result-name (intern (format nil "RESULT-~D" i))))
(:args ,@(args))
,@(temps)
(:results ,@(results))
+ (:node-var ,node)
(:generator ,(+ 50 num-args num-results)
,@(moves (temp-names) (arg-names))
- ;; If speed not more important than size, duplicate the
+ ;; If speed is at least as important as size, duplicate the
;; effect of the ENTER with discrete instructions. Takes
- ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
- (cond (t ;(policy node (>= speed space))
- (inst mov ebx esp-tn)
- ;; Dummy for return address
+ ;; 3+4+4=11 bytes as opposed to 1+4=5 bytes.
+ (cond ((policy ,node (>= speed space))
+ (inst sub esp-tn (fixnumize 3))
+ (inst mov (make-ea :dword :base esp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))
+ ebp-tn)
+ (inst lea ebp-tn (make-ea :dword :base esp-tn
+ :disp (frame-byte-offset
+ (+ sp->fp-offset
+ -3
+ ocfp-save-offset)))))
+ (t
+ ;; Dummy for return address.
(inst push ebp-tn)
- ;; Save the old-fp
- (inst push ebp-tn)
- ;; Ensure that at least three slots are available; one
- ;; above, two more needed.
- (inst sub esp-tn (fixnumize 1))
- (inst mov ebp-tn ebx))
- #+(or) (t
- (inst enter (fixnumize 2))
- ;; The enter instruction pushes EBP and then copies
- ;; ESP into EBP. We want the new EBP to be the
- ;; original ESP, so we fix it up afterwards.
- (inst add ebp-tn (fixnumize 1))))
+ (inst enter (fixnumize 1))))
,(if (zerop num-args)
'(inst xor ecx ecx)
\f
;;;; miscellaneous function call parameters
-;;; offsets of special stack frame locations
-(def!constant ocfp-save-offset 1)
+;;; Offsets of special stack frame locations relative to EBP.
+;;;
+;;; Consider the standard prologue PUSH EBP; MOV EBP, ESP: the return
+;;; address is at EBP+4, the old control stack frame pointer is at
+;;; EBP, the magic 3rd slot is at EBP-4. Then come the locals from
+;;; EBP-8 on.
(def!constant return-pc-save-offset 0)
+(def!constant ocfp-save-offset 1)
+;;; Let SP be the stack pointer before CALLing, and FP is the frame
+;;; pointer after the standard prologue. SP +
+;;; FRAME-WORD-OFFSET(SP->FP-OFFSET + I) = FP + FRAME-WORD-OFFSET(I).
+(def!constant sp->fp-offset 2)
(declaim (inline frame-word-offset))
(defun frame-word-offset (index)
- (- (1+ index)))
+ (- (1- index)))
(declaim (inline frame-byte-offset))
(defun frame-byte-offset (index)
static int
x86_call_context (void *fp, void **ra, void **ocfp)
{
- void *lisp_ocfp;
- void *lisp_ra;
void *c_ocfp;
void *c_ra;
- int lisp_valid_p, c_valid_p;
+ int c_valid_p;
if (!stack_pointer_p(fp))
return 0;
c_ocfp = *((void **) fp);
c_ra = *((void **) fp + 1);
- lisp_ocfp = *((void **) fp - 2);
- lisp_ra = *((void **) fp - 1);
- lisp_valid_p = (lisp_ocfp > fp
- && stack_pointer_p(lisp_ocfp)
- && ra_pointer_p(lisp_ra));
c_valid_p = (c_ocfp > fp
&& stack_pointer_p(c_ocfp)
&& ra_pointer_p(c_ra));
- if (lisp_valid_p && c_valid_p) {
- void *lisp_path_fp;
- void *c_path_fp;
- void *dummy;
-
- int lisp_path_p = x86_call_context(lisp_ocfp, &lisp_path_fp, &dummy);
- int c_path_p = x86_call_context(c_ocfp, &c_path_fp, &dummy);
-
- if (lisp_path_p && c_path_p) {
-#if defined __FreeBSD__ && __FreeBSD_version > 400000
- if (lisp_ocfp > c_ocfp)
- *ra = lisp_ra, *ocfp = lisp_ocfp;
- else
- *ra = c_ra, *ocfp = c_ocfp;
-#else
- *ra = lisp_ra, *ocfp = lisp_ocfp;
-#endif
- }
- else if (lisp_path_p)
- *ra = lisp_ra, *ocfp = lisp_ocfp;
- else if (c_path_p)
- *ra = c_ra, *ocfp = c_ocfp;
- else
- return 0;
- }
- else if (lisp_valid_p)
- *ra = lisp_ra, *ocfp = lisp_ocfp;
- else if (c_valid_p)
+ if (c_valid_p)
*ra = c_ra, *ocfp = c_ocfp;
else
return 0;
xor %rbx,%rbx # available
/* Alloc new frame. */
- mov %rsp,%rbx # The current sp marks start of new frame.
- push %rbp # dummy for return address
- push %rbp # fp in save location S0
+ push %rbp # Dummy for return address
+ push %rbp # fp in save location S1
+ mov %rsp,%rbp # The current sp marks start of new frame.
sub $8,%rsp # Ensure 3 slots are allocated, two above.
- mov %rbx,%rbp # Switch to new frame.
Lcall:
call *CLOSURE_FUN_OFFSET(%rax)
#endif
/* Alloc new frame. */
- mov %esp,%ebx # The current sp marks start of new frame.
- push %ebp # dummy for return address
+ push %ebp # Dummy for return address
push %ebp # fp in save location S1
+ mov %esp,%ebp # The current sp marks start of new frame.
sub $4,%esp # Ensure 3 slots are allocated, two above.
- mov %ebx,%ebp # Switch to new frame.
call *CLOSURE_FUN_OFFSET(%eax)
;;; 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.27.13"
+"1.0.27.14"
projects / sbcl.git / commitdiff