X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fnlx.lisp;h=2c24331baf2ab65a6f1048c3169adc6492bd016e;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=0c2af51e196835eb09e60520e3ede43f02c1fff1;hpb=50305b602c3953440af716137a56f50cd204375d;p=sbcl.git diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index 0c2af51..2c24331 100644 --- a/src/compiler/x86/nlx.lisp +++ b/src/compiler/x86/nlx.lisp @@ -12,55 +12,48 @@ (in-package "SB!VM") ;;; Make an environment-live stack TN for saving the SP for NLX entry. -(!def-vm-support-routine make-nlx-sp-tn (env) +(defun make-nlx-sp-tn (env) (physenv-live-tn (make-representation-tn *fixnum-primitive-type* any-reg-sc-number) env)) ;;; Make a TN for the argument count passing location for a non-local entry. -(!def-vm-support-routine make-nlx-entry-argument-start-location () +(defun make-nlx-entry-arg-start-location () (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ebx-offset)) (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. ;;;; ;;;; These VOPs are used in the reentered function to restore the ;;;; appropriate dynamic environment. Currently we only save the -;;;; Current-Catch, the eval stack pointer, and the alien stack -;;;; pointer. +;;;; Current-Catch and the alien stack pointer. (Before sbcl-0.7.0, +;;;; when there were IR1 and byte interpreters, we had to save +;;;; the interpreter "eval stack" too.) ;;;; -;;;; We don't need to save/restore the current unwind-protect, since -;;;; unwind-protects are implicitly processed during unwinding. +;;;; We don't need to save/restore the current UNWIND-PROTECT, since +;;;; UNWIND-PROTECTs are implicitly processed during unwinding. ;;;; ;;;; 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/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 eval *eval-stack-top*) - (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 eval *eval-stack-top*) - (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))) @@ -70,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 @@ -83,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. +;;; 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 (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) @@ -152,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) @@ -195,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 @@ -210,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)))) @@ -235,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) :to :load :target saved-function)) + (:arg-types system-area-pointer system-area-pointer t) + (:temporary (:sc sap-reg) temp) + (:temporary (:sc descriptor-reg :offset ebx-offset) saved-function) + (: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. It turns out that EBX is preserved as part of the + ;; normal multiple-value handling of an unwind, so use that. + (move saved-function function) + + ;; 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 + + ;; Move our saved function to where we want it now. + (move block saved-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)))))