X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fnlx.lisp;h=96d2ca4c4f3421f5dcedd6290c1863edbd102959;hb=08917ec0d00a781a1089922a5419b7f136cdf08f;hp=c382da72411ffb5fd8205628617ff8a61c7698d1;hpb=a0a198faba322eccaf947862b59946aed99b2347;p=sbcl.git diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index c382da7..96d2ca4 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. @@ -40,26 +40,20 @@ ;;;; ;;;; We don't need to save the BSP, because that is handled automatically. -;;; Return a list of TNs that can be used to snapshot the dynamic -;;; state for use with the SAVE- and RESTORE-DYNAMIC-ENVIRONMENT VOPs. -(!def-vm-support-routine make-dynamic-state-tns () - (make-n-tns 3 *backend-t-primitive-type*)) - (define-vop (save-dynamic-state) (:results (catch :scs (descriptor-reg)) - (eval :scs (descriptor-reg)) - (alien-stack :scs (descriptor-reg))) + (alien-stack :scs (descriptor-reg))) (:generator 13 - (load-symbol-value catch *current-catch-block*) - (load-symbol-value alien-stack *alien-stack*))) + (load-tl-symbol-value catch *current-catch-block*) + (load-tl-symbol-value alien-stack *alien-stack*))) (define-vop (restore-dynamic-state) (:args (catch :scs (descriptor-reg)) - (eval :scs (descriptor-reg)) - (alien-stack :scs (descriptor-reg))) + (alien-stack :scs (descriptor-reg))) + #!+sb-thread (:temporary (:sc unsigned-reg) temp) (:generator 10 - (store-symbol-value catch *current-catch-block*) - (store-symbol-value alien-stack *alien-stack*))) + (store-tl-symbol-value catch *current-catch-block* temp) + (store-tl-symbol-value alien-stack *alien-stack* temp))) (define-vop (current-stack-pointer) (:results (res :scs (any-reg control-stack))) @@ -69,7 +63,7 @@ (define-vop (current-binding-pointer) (:results (res :scs (any-reg descriptor-reg))) (:generator 1 - (load-symbol-value res *binding-stack-pointer*))) + (load-binding-stack-pointer res))) ;;;; unwind block hackery @@ -82,66 +76,87 @@ (:results (block :scs (any-reg))) (:generator 22 (inst lea block (catch-block-ea tn)) - (load-symbol-value temp *current-unwind-protect-block*) + (load-tl-symbol-value temp *current-unwind-protect-block*) (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 mov temp (make-ea :dword :disp 0) :fs) + (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 (define-vop (make-catch-block) (:args (tn) - (tag :scs (any-reg descriptor-reg) :to (:result 1))) + (tag :scs (any-reg descriptor-reg) :to (:result 1))) (:info entry-label) (:results (block :scs (any-reg))) (:temporary (:sc descriptor-reg) temp) (:generator 44 (inst lea block (catch-block-ea tn)) - (load-symbol-value temp *current-unwind-protect-block*) + (load-tl-symbol-value temp *current-unwind-protect-block*) (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 mov temp (make-ea :dword :disp 0) :fs) + (storew temp block unwind-block-next-seh-frame-slot)) (storew tag block catch-block-tag-slot) - (load-symbol-value temp *current-catch-block*) + (load-tl-symbol-value temp *current-catch-block*) (storew temp block catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) + (store-tl-symbol-value block *current-catch-block* temp))) ;;; Just set the current unwind-protect to TN's address. This instantiates an ;;; unwind block as an unwind-protect. (define-vop (set-unwind-protect) (:args (tn)) - (:temporary (:sc unsigned-reg) new-uwp) + (:temporary (:sc unsigned-reg) new-uwp #!+sb-thread tls #!+win32 seh-frame) (:generator 7 (inst lea new-uwp (catch-block-ea tn)) - (store-symbol-value new-uwp *current-unwind-protect-block*))) + #!+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 mov (make-ea :dword :disp 0) seh-frame :fs)) + (store-tl-symbol-value new-uwp *current-unwind-protect-block* tls))) (define-vop (unlink-catch-block) - (:temporary (:sc unsigned-reg) block) + (:temporary (:sc unsigned-reg) #!+sb-thread tls block) (:policy :fast-safe) (:translate %catch-breakup) (:generator 17 - (load-symbol-value block *current-catch-block*) + (load-tl-symbol-value block *current-catch-block*) (loadw block block catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) + (store-tl-symbol-value block *current-catch-block* tls))) (define-vop (unlink-unwind-protect) - (:temporary (:sc unsigned-reg) block) + ;; 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-symbol-value block *current-unwind-protect-block*) + (load-tl-symbol-value block *current-unwind-protect-block*) + #!+win32 + (progn + (loadw seh-frame block unwind-block-next-seh-frame-slot) + (inst mov (make-ea :dword :disp 0) seh-frame :fs)) (loadw block block unwind-block-current-uwp-slot) - (store-symbol-value block *current-unwind-protect-block*))) + (store-tl-symbol-value block *current-unwind-protect-block* tls))) ;;;; NLX entry VOPs (define-vop (nlx-entry) ;; Note: we can't list an sc-restriction, 'cause any load vops would ;; be inserted before the return-pc label. (:args (sp) - (start) - (count)) + (start) + (count)) (:results (values :more t)) (:temporary (:sc descriptor-reg) move-temp) (:info label nvals) @@ -151,42 +166,49 @@ (emit-label label) (note-this-location vop :non-local-entry) (cond ((zerop nvals)) - ((= nvals 1) - (let ((no-values (gen-label))) - (inst mov (tn-ref-tn values) nil-value) - (inst jecxz no-values) - (loadw (tn-ref-tn values) start -1) - (emit-label no-values))) - (t - (collect ((defaults)) - (do ((i 0 (1+ i)) - (tn-ref values (tn-ref-across tn-ref))) - ((null tn-ref)) - (let ((default-lab (gen-label)) - (tn (tn-ref-tn tn-ref))) - (defaults (cons default-lab tn)) - - (inst cmp count (fixnumize i)) - (inst jmp :le default-lab) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start (- (1+ i)))) - ((control-stack) - (loadw move-temp start (- (1+ i))) - (inst mov tn move-temp))))) - (let ((defaulting-done (gen-label))) - (emit-label defaulting-done) - (assemble (*elsewhere*) - (dolist (def (defaults)) - (emit-label (car def)) - (inst mov (cdr def) nil-value)) - (inst jmp defaulting-done)))))) + ((= nvals 1) + (let ((no-values (gen-label))) + (inst mov (tn-ref-tn values) nil-value) + (inst jecxz no-values) + (loadw (tn-ref-tn values) start -1) + (emit-label no-values))) + (t + ;; FIXME: this is mostly copied from + ;; DEFAULT-UNKNOWN-VALUES. + (collect ((defaults)) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref)) + (first-stack-arg-p (= i register-arg-count))) + (defaults (cons default-lab (cons tn first-stack-arg-p))) + (inst cmp count (fixnumize i)) + (inst jmp :le default-lab) + (when first-stack-arg-p + (storew edx-tn ebx-tn -1)) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start (frame-word-offset (+ sp->fp-offset i)))) + ((control-stack) + (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) + (assemble (*elsewhere*) + (dolist (default (defaults)) + (emit-label (car default)) + (when (cddr default) + (inst push edx-tn)) + (inst mov (second default) nil-value)) + (inst jmp defaulting-done)))))) (inst mov esp-tn sp))) (define-vop (nlx-entry-multiple) (:args (top) - (source) - (count :target ecx)) + (source) + (count :target ecx)) ;; Again, no SC restrictions for the args, 'cause the loading would ;; happen before the entry label. (:info label) @@ -194,7 +216,7 @@ (:temporary (:sc unsigned-reg :offset esi-offset) esi) (:temporary (:sc unsigned-reg :offset edi-offset) edi) (:results (result :scs (any-reg) :from (:argument 0)) - (num :scs (any-reg control-stack))) + (num :scs (any-reg control-stack))) (:save-p :force-to-stack) (:vop-var vop) (:generator 30 @@ -209,16 +231,16 @@ (move result edi) (inst sub edi n-word-bytes) - (move ecx count) ; fixnum words == bytes + (move ecx count) ; fixnum words == bytes (move num ecx) - (inst shr ecx word-shift) ; word count for + (inst shr ecx word-shift) ; word count for ;; If we got zero, we be done. - (inst jecxz done) + (inst jecxz DONE) ;; Copy them down. (inst std) (inst rep) (inst movs :dword) - + (inst cld) DONE ;; Reset the CSP at last moved arg. (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)))) @@ -234,3 +256,54 @@ (: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 n-word-bytes)) + ;; 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 (* (- 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)) + + ;; Call it + (inst jmp (make-ea :dword :base block + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag)))))