X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fassembly%2Fx86%2Fassem-rtns.lisp;h=9efecb9f28c4cbdaf7416d9cfd83019946b75e5c;hb=440baf2d4f88579609615c6cbf598c336fb07445;hp=108acb4c08d3fec2cd6853d5b3059ccfecfd6835;hpb=dc038a23a34c53e44b6de20b3e391cc05470e4af;p=sbcl.git diff --git a/src/assembly/x86/assem-rtns.lisp b/src/assembly/x86/assem-rtns.lisp index 108acb4..9efecb9 100644 --- a/src/assembly/x86/assem-rtns.lisp +++ b/src/assembly/x86/assem-rtns.lisp @@ -20,40 +20,50 @@ #+sb-assembling ;; We don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) - (;; These four are really arguments. - (:temp eax unsigned-reg eax-offset) - (:temp ebx unsigned-reg ebx-offset) + (;; These are really arguments. (:temp ecx unsigned-reg ecx-offset) (:temp esi unsigned-reg esi-offset) ;; These we need as temporaries. + (:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset) (:temp edx unsigned-reg edx-offset) (:temp edi unsigned-reg edi-offset)) ;; Pick off the cases where everything fits in register args. - (inst jecxz zero-values) + (inst jecxz ZERO-VALUES) (inst cmp ecx (fixnumize 1)) - (inst jmp :e one-value) + (inst jmp :e ONE-VALUE) (inst cmp ecx (fixnumize 2)) - (inst jmp :e two-values) + (inst jmp :e TWO-VALUES) (inst cmp ecx (fixnumize 3)) - (inst jmp :e three-values) + (inst jmp :e THREE-VALUES) - ;; Save the count, because the loop is going to destroy it. - (inst mov edx ecx) + ;; 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))) + (inst mov ebp-tn (make-ea :dword :base ebp-tn + :disp (frame-byte-offset ocfp-save-offset))) ;; Blit the values down the stack. Note: there might be overlap, so ;; we have to be careful not to clobber values before we've read - ;; them. Because the stack builds down, we are coping to a larger + ;; them. Because the stack builds down, we are copying to a larger ;; address. Therefore, we need to iterate from larger addresses to ;; smaller addresses. pfw-this says copy ecx words from esi to edi ;; counting down. - (inst shr ecx 2) ; fixnum to raw word count - (inst std) ; count down - (inst sub esi 4) ; ? + (inst shr ecx (1- n-lowtag-bits)) + (inst std) ; count down + (inst sub esi n-word-bytes) (inst lea edi (make-ea :dword :base ebx :disp (- n-word-bytes))) (inst rep) (inst movs :dword) + (inst cld) ;; Restore the count. (inst mov ecx edx) @@ -67,36 +77,52 @@ (loadw esi ebx -3) ;; And back we go. - (inst jmp eax) + (inst stc) + (inst push eax) + (inst ret) ;; Handle the register arg cases. ZERO-VALUES - (move esp-tn ebx) + (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 jmp eax) - - ONE-VALUE ; Note: we can get this, because the return-multiple vop - ; doesn't check for this case when size > speed. + (inst mov esp-tn ebp-tn) + (inst stc) + (inst pop ebp-tn) + (inst ret) + + ;; Note: we can get this, because the return-multiple vop doesn't + ;; check for this case when size > speed. + ONE-VALUE (loadw edx esi -1) - (inst mov esp-tn ebx) - (inst add eax 2) - (inst jmp eax) + (inst mov esp-tn ebp-tn) + (inst clc) + (inst pop ebp-tn) + (inst ret) TWO-VALUES + (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 (* -2 n-word-bytes))) - (inst jmp eax) + (inst mov esp-tn ebp-tn) + (inst stc) + (inst pop ebp-tn) + (inst ret) THREE-VALUES + (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 (* -3 n-word-bytes))) - (inst jmp eax)) + (inst mov esp-tn ebp-tn) + (inst stc) + (inst pop ebp-tn) + (inst ret)) ;;;; TAIL-CALL-VARIABLE @@ -126,49 +152,49 @@ (move ecx esi) (inst sub ecx esp-tn) - ;; Check for all the args fitting the the registers. + ;; Check for all the args fitting the registers. (inst cmp ecx (fixnumize 3)) (inst jmp :le REGISTER-ARGS) - ;; Save the OLD-FP and RETURN-PC because the blit it going to trash - ;; those stack locations. Save the ECX, because the loop is going - ;; to trash it. - (pushw ebp-tn -1) - (loadw ebx ebp-tn -2) + ;; Save the OLD-FP and RETURN-PC because the blit is going to trash + ;; those stack locations. Save the ECX, because the loop is going to + ;; trash it. + (pushw ebp-tn (frame-word-offset ocfp-save-offset)) + (loadw ebx ebp-tn (frame-word-offset return-pc-save-offset)) (inst push ecx) ;; Do the blit. Because we are coping from smaller addresses to ;; larger addresses, we have to start at the largest pair and work ;; our way down. - (inst shr ecx 2) ; fixnum to raw words - (inst std) ; count down - (inst lea edi (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) + (inst shr ecx (1- n-lowtag-bits)) + (inst std) ; count down + (inst lea edi (make-ea :dword :base ebp-tn :disp (frame-byte-offset 0))) (inst sub esi (fixnumize 1)) (inst rep) (inst movs :dword) + (inst cld) ;; Load the register arguments carefully. - (loadw edx ebp-tn -1) + (loadw edx ebp-tn (frame-word-offset ocfp-save-offset)) ;; Restore OLD-FP and ECX. (inst pop ecx) - (popw ebp-tn -1) ; overwrites a0 + ;; Overwrites a1 + (popw ebp-tn (frame-word-offset ocfp-save-offset)) ;; Blow off the stack above the arguments. (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)) ;; remaining register args - (loadw edi ebp-tn -2) - (loadw esi ebp-tn -3) + (inst mov edi edx) + (loadw edx ebp-tn (frame-word-offset 0)) + (loadw esi ebp-tn (frame-word-offset 2)) ;; Push the (saved) return-pc so it looks like we just called. (inst push ebx) ;; And jump into the function. - (inst jmp - (make-ea :byte :base eax - :disp (- (* closure-fun-slot n-word-bytes) - fun-pointer-lowtag))) + (inst jmp (make-ea-for-object-slot eax closure-fun-slot fun-pointer-lowtag)) ;; All the arguments fit in registers, so load them. REGISTER-ARGS @@ -178,38 +204,46 @@ ;; 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 -2) + (pushw ebp-tn (frame-word-offset return-pc-save-offset)) ;; And away we go. - (inst jmp (make-ea :byte :base eax - :disp (- (* closure-fun-slot n-word-bytes) - fun-pointer-lowtag)))) + (inst jmp (make-ea-for-object-slot eax closure-fun-slot fun-pointer-lowtag))) (define-assembly-routine (throw - (:return-style :none)) - ((:arg target (descriptor-reg any-reg) edx-offset) - (:arg start any-reg ebx-offset) - (:arg count any-reg ecx-offset) - (:temp catch any-reg eax-offset)) + (:return-style :raw)) + ((:arg target (descriptor-reg any-reg) edx-offset) + (:arg start any-reg ebx-offset) + (:arg count any-reg ecx-offset) + (:temp catch any-reg eax-offset)) (declare (ignore start count)) - (load-symbol-value catch *current-catch-block*) + (load-tl-symbol-value catch *current-catch-block*) LOOP - (let ((error (generate-error-code nil unseen-throw-tag-error target))) - (inst or catch catch) ; check for NULL pointer + (let ((error (gen-label))) + (assemble (*elsewhere*) + (emit-label error) + + ;; Fake up a stack frame so that backtraces come out right. + (inst push ebp-tn) + (inst mov ebp-tn esp-tn) + + (emit-error-break nil error-trap + (error-number-or-lose 'unseen-throw-tag-error) + (list target))) + (inst test catch catch) ; check for NULL pointer (inst jmp :z error)) (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) - (inst jmp :e exit) + (inst jmp :e EXIT) (loadw catch catch catch-block-previous-catch-slot) - (inst jmp loop) + (inst jmp LOOP) EXIT @@ -218,28 +252,29 @@ ;;;; non-local exit noise +#!-win32 (define-assembly-routine (unwind - (:return-style :none) - (:translate %continue-unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) eax-offset) - (:arg start (any-reg descriptor-reg) ebx-offset) - (:arg count (any-reg descriptor-reg) ecx-offset) - (:temp uwp unsigned-reg esi-offset)) + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset) + (:temp uwp unsigned-reg esi-offset)) (declare (ignore start count)) - (let ((error (generate-error-code nil invalid-unwind-error))) - (inst or block block) ; check for NULL pointer + (let ((error (generate-error-code nil 'invalid-unwind-error))) + (inst test block block) ; check for NULL pointer (inst jmp :z error)) - (load-symbol-value uwp *current-unwind-protect-block*) + (load-tl-symbol-value uwp *current-unwind-protect-block*) ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in ;; argument's CURRENT-UWP-SLOT? (inst cmp uwp - (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) + (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) ;; If a match, return to context in arg block. - (inst jmp :e do-exit) + (inst jmp :e DO-EXIT) ;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context. ;; Important! Must save (and return) the arg 'block' for later use!! @@ -247,7 +282,9 @@ (move block uwp) ;; Set next unwind protect context. (loadw uwp uwp unwind-block-current-uwp-slot) - (store-symbol-value uwp *current-unwind-protect-block*) + ;; we're about to reload ebp anyway, so let's borrow it here as a + ;; temporary. Hope this works + (store-tl-symbol-value uwp *current-unwind-protect-block* ebp-tn) DO-EXIT @@ -257,5 +294,199 @@ ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and ;; count in ecx-tn. - (inst jmp (make-ea :byte :base block - :disp (* unwind-block-entry-pc-slot n-word-bytes)))) + (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0))) + + +;;;; Win32 non-local exit noise + +#!+win32 +(define-assembly-routine (unwind + (:return-style :none) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil 'invalid-unwind-error))) + (inst test block block) ; check for NULL pointer + (inst jmp :z error)) + + ;; Save all our registers, as we're about to clobber them. + (inst pusha) + + ;; Find the SEH frame surrounding our target. + (loadw ecx-tn block unwind-block-next-seh-frame-slot) + + ;; This section copied from VOP CALL-OUT. + ;; Setup the NPX for C; all the FP registers need to be + ;; empty; pop them all. + (dotimes (i 8) + (inst fstp fr0-tn)) + + ;; I'm unlikely to ever forget this again. + (inst cld) + + ;; Set up a bogus stack frame for RtlUnwind to pick its return + ;; address from. (Yes, this is how RtlUnwind works.) + (inst push (make-fixup 'win32-unwind-tail :assembly-routine)) + (inst push ebp-tn) + (inst mov ebp-tn esp-tn) + + ;; Actually call out for the unwind. + (inst push 0) + (inst push 0) + (inst push 0) + (inst push ecx-tn) + (inst call (make-fixup "RtlUnwind" :foreign))) + +;; We want no VOP for this one and for it to only happen on Win32 +;; targets. Hence the following disaster. +#!+#.(cl:if (cl:member sb-assembling cl:*features*) win32 '(or)) +(define-assembly-routine + (win32-unwind-tail (:return-style :none)) + ((:temp block unsigned-reg eax-offset)) + + ;; The unwind returns here. Had to use a VOP for this because + ;; PUSH won't accept a label as an argument. + + ;; Clean up the bogus stack frame we pushed for the unwind. + (inst pop ebp-tn) + (inst pop esi-tn) ;; Random scratch register. + + ;; This section based on VOP CALL-OUT. + ;; Restore the NPX for lisp; ensure no regs are empty + (dotimes (i 8) + (inst fldz)) + + ;; Restore our regs. + (inst popa) + + ;; By now we've unwound all the UWP frames required, so we + ;; just jump to our target block. + (loadw ebp-tn block unwind-block-current-cont-slot) + + ;; Nlx-entry expects the arg start in ebx-tn and the arg count + ;; in ecx-tn. Fortunately, that's where they are already. + (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0))) + + +;;;; Win32 UWP block SEH interface. + +;; We want no VOP for this one and for it to only happen on Win32 +;; targets. Hence the following disaster. +#!+#.(cl:if (cl:member sb-assembling cl:*features*) win32 '(or)) +(define-assembly-routine + (uwp-seh-handler (:return-style :none)) + ((:temp block unsigned-reg eax-offset)) + + ;; We get called for any exception which happens within our + ;; dynamic contour that isn't handled below us, and for + ;; unwinding. + + ;; For the exceptions we just return ExceptionContinueSearch. + + ;; Find the exception record. + (inst mov eax-tn (make-ea :dword :base esp-tn :disp 4)) + + ;; Check unwind flags. + (inst test (make-ea :byte :base eax-tn :disp 4) 6) ; EH_UNWINDING | EH_EXIT_UNWIND + + ;; To see if we're unwinding or not. + (inst jmp :nz UNWINDING) + + ;; We're not unwinding, so we're not interested. + (inst mov eax-tn 1) ;; exception-continue-search + (inst ret) + + ;; For the unwinds we establish a basic environment as per + ;; call_into_lisp, but without the extra SEH frame (the theory + ;; being that we're already in a Lisp SEH context), and invoke + ;; our UWP block to unwind itself. + + ;; FIXME: Do we need to establish an SEH frame anyway? And do + ;; we need to do the same stack frame hackery for the debugger + ;; as we do for the main exception handler? + + ;; When the UWP block calls %continue-unwind, we come back to + ;; the next assembly routine, below, which reinitializes for C + ;; and returns to the Win32 unwind machinery. + + ;; If the UWP block sees fit to do a non-local exit, things + ;; Just Work, thanks to the Win32 API being sanely designed + ;; and our complying with it. + + ;; We also must update *current-unwind-protect-block* before + ;; calling the cleanup function. + + UNWINDING + + ;; Save all registers (overkill) + (inst pusha) + + ;; Establish our stack frame. + (inst mov ebp-tn esp-tn) + + ;; This section based on VOP CALL-OUT. + ;; Restore the NPX for lisp; ensure no regs are empty + (dotimes (i 8) + (inst fldz)) + + ;; Find our unwind-block by way of our SEH frame. + (inst mov block (make-ea :dword :base ebp-tn :disp #x28)) + (inst lea block (make-ea :dword :base block + :disp (- (* unwind-block-next-seh-frame-slot + n-word-bytes)))) + + ;; Update *CURRENT-UNWIND-PROTECT-BLOCK*. + (loadw ebx-tn block unwind-block-current-uwp-slot) + (store-tl-symbol-value ebx-tn *current-unwind-protect-block* ecx-tn) + + ;; Uwp-entry expects some things in known locations so that they can + ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and + ;; count in ecx-tn. We don't actually have any of that here, but we + ;; do need to have access to our own stack frame, so we hijack the + ;; known locations to cover our own state. + + (inst xor ebx-tn ebx-tn) + (inst xor ecx-tn ecx-tn) + (inst mov ebx-tn ebp-tn) + (loadw ebp-tn block unwind-block-current-cont-slot) + (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0))) + +#!+win32 +(define-assembly-routine (continue-unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset)) + (declare (ignore block count)) + ;; The args here are mostly ignored because we're using the + ;; win32 unwind mechanism and keep all that elsewhere. The + ;; exception is START, which we use to pass the saved EBP for + ;; our exception handler. + + ;; "All" we have to do here is reload our EBP, reestablish a C + ;; environment, and return ExceptionContinueSearch. The OS + ;; handles the rest. + + ;; Restore our frame pointer. + (inst mov esp-tn start) + + ;; This section copied from VOP CALL-OUT. + ;; Setup the NPX for C; all the FP registers need to be + ;; empty; pop them all. + (dotimes (i 8) + (inst fstp fr0-tn)) + + ;; I'm unlikely to ever forget this again. + (inst cld) + + ;; Restore our saved registers + (inst popa) + + ;; And we're done. + (inst mov eax-tn 1) ;; exception-continue-search + (inst ret))