X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fnlx.lisp;h=5a1314cb75a193c29a787077456fdfb6f53aade2;hb=edf8d3701ba59bd9f0c1bd027f3179b98250cfd0;hp=862688f9ee01f19a1a3433511509f86c885536ee;hpb=0d871fd7a98fc4af92a8b942a1154761466ad8c9;p=sbcl.git diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index 862688f..5a1314c 100644 --- a/src/compiler/x86/nlx.lisp +++ b/src/compiler/x86/nlx.lisp @@ -24,7 +24,7 @@ (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)))) ;;;; Save and restore dynamic environment. @@ -63,7 +63,7 @@ (define-vop (current-binding-pointer) (:results (res :scs (any-reg descriptor-reg))) (:generator 1 - (load-tl-symbol-value res *binding-stack-pointer*))) + (load-binding-stack-pointer res))) ;;;; unwind block hackery @@ -80,7 +80,12 @@ (storew temp block unwind-block-current-uwp-slot) (storew ebp-tn block unwind-block-current-cont-slot) (storew (make-fixup nil :code-object entry-label) - block catch-block-entry-pc-slot))) + block catch-block-entry-pc-slot) + #!+win32 + (progn + (inst fs-segment-prefix) + (inst mov temp (make-ea :dword :disp 0)) + (storew temp block unwind-block-next-seh-frame-slot)))) ;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified ;;; tag, and link the block into the CURRENT-CATCH list @@ -97,6 +102,11 @@ (storew ebp-tn block unwind-block-current-cont-slot) (storew (make-fixup nil :code-object entry-label) block catch-block-entry-pc-slot) + #!+win32 + (progn + (inst fs-segment-prefix) + (inst mov temp (make-ea :dword :disp 0)) + (storew temp block unwind-block-next-seh-frame-slot)) (storew tag block catch-block-tag-slot) (load-tl-symbol-value temp *current-catch-block*) (storew temp block catch-block-previous-catch-slot) @@ -106,9 +116,18 @@ ;;; unwind block as an unwind-protect. (define-vop (set-unwind-protect) (:args (tn)) - (:temporary (:sc unsigned-reg) new-uwp #!+sb-thread tls) + (:temporary (:sc unsigned-reg) new-uwp #!+sb-thread tls #!+win32 seh-frame) (:generator 7 (inst lea new-uwp (catch-block-ea tn)) + #!+win32 + (progn + (storew (make-fixup 'uwp-seh-handler :assembly-routine) + new-uwp unwind-block-seh-frame-handler-slot) + (inst lea seh-frame + (make-ea-for-object-slot new-uwp + unwind-block-next-seh-frame-slot 0)) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :disp 0) seh-frame)) (store-tl-symbol-value new-uwp *current-unwind-protect-block* tls))) (define-vop (unlink-catch-block) @@ -121,11 +140,17 @@ (store-tl-symbol-value block *current-catch-block* tls))) (define-vop (unlink-unwind-protect) - (:temporary (:sc unsigned-reg) block #!+sb-thread tls) + ;; NOTE: When we have both #!+sb-thread and #!+win32, we only need one temp + (:temporary (:sc unsigned-reg) block #!+sb-thread tls #!+win32 seh-frame) (:policy :fast-safe) (:translate %unwind-protect-breakup) (:generator 17 (load-tl-symbol-value block *current-unwind-protect-block*) + #!+win32 + (progn + (loadw seh-frame block unwind-block-next-seh-frame-slot) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :disp 0) seh-frame)) (loadw block block unwind-block-current-uwp-slot) (store-tl-symbol-value block *current-unwind-protect-block* tls))) @@ -164,9 +189,9 @@ (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) @@ -228,3 +253,53 @@ (:generator 0 (emit-label label) (note-this-location vop :non-local-entry))) + +(define-vop (unwind-to-frame-and-call) + (:args (ofp :scs (descriptor-reg)) + (uwp :scs (descriptor-reg)) + (function :scs (descriptor-reg))) + (:arg-types system-area-pointer system-area-pointer t) + (:temporary (:sc sap-reg) temp) + (:temporary (:sc unsigned-reg :offset eax-offset) block) + (:generator 22 + ;; Store the function into a non-stack location, since we'll be + ;; unwinding the stack and destroying register contents before we + ;; use it. + (store-tl-symbol-value function + *unwind-to-frame-function* + temp) + + ;; Allocate space for magic UWP block. + (inst sub esp-tn unwind-block-size) + ;; Set up magic catch / UWP block. + (move block esp-tn) + (loadw temp uwp sap-pointer-slot other-pointer-lowtag) + (storew temp block unwind-block-current-uwp-slot) + (loadw temp ofp sap-pointer-slot other-pointer-lowtag) + (storew temp block unwind-block-current-cont-slot) + + (storew (make-fixup nil :code-object entry-label) + block + catch-block-entry-pc-slot) + + ;; Run any required UWPs. + (inst jmp (make-fixup 'unwind :assembly-routine)) + ENTRY-LABEL + + ;; Load function from symbol + (load-tl-symbol-value block *unwind-to-frame-function*) + + ;; No parameters + (inst xor ecx-tn ecx-tn) + + ;; Clear the stack + (inst lea esp-tn + (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes))) + + ;; Push the return-pc so it looks like we just called. + (pushw ebp-tn -2) + + ;; Call it + (inst jmp (make-ea :dword :base block + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag)))))