X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fnlx.lisp;h=e3fe28d312a518d0662d53e3ce789ba932e026b3;hb=debae3c18d31b5222be4d5de8dcb2601336e24a4;hp=b69a533e30c29213505c83d91d59970ae6725d33;hpb=581e3d62de8cb37e13ad9db63e5537c0f962be28;p=sbcl.git diff --git a/src/compiler/ppc/nlx.lisp b/src/compiler/ppc/nlx.lisp index b69a533..e3fe28d 100644 --- a/src/compiler/ppc/nlx.lisp +++ b/src/compiler/ppc/nlx.lisp @@ -1,16 +1,26 @@ -;;; Written by Rob MacLachlan -;;; +;;;; the PPC definitions of VOPs used for non-local exit (throw, +;;;; lexical exit, etc.) + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + (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* immediate-arg-scn) env)) ;;; Make a TN for the argument count passing location for a ;;; non-local entry. -(!def-vm-support-routine make-nlx-entry-arg-start-location () +(defun make-nlx-entry-arg-start-location () (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)) @@ -22,34 +32,29 @@ ;;; additional stacks, then this would be the place to restore the top ;;; pointers. - -;;; 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 4 *backend-t-primitive-type*)) - (define-vop (save-dynamic-state) (:results (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg))) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg))) (:vop-var vop) (:generator 13 - (load-symbol-value catch *current-catch-block*) + (load-tl-symbol-value catch *current-catch-block*) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (move nfp cur-nfp))) + (move nfp cur-nfp))) (move nsp nsp-tn))) (define-vop (restore-dynamic-state) (:args (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg))) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg))) + #!+sb-thread (:temporary (:scs (any-reg)) temp) (:vop-var vop) (:generator 10 - (store-symbol-value catch *current-catch-block*) + (store-tl-symbol-value catch *current-catch-block* temp) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (move cur-nfp nfp))) + (move cur-nfp nfp))) (move nsp-tn nsp))) (define-vop (current-stack-pointer) @@ -76,13 +81,13 @@ (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (non-descriptor-reg)) ndescr) (:generator 22 - (inst addi block cfp-tn (* (tn-offset tn) sb!vm:n-word-bytes)) - (load-symbol-value temp *current-unwind-protect-block*) - (storew temp block sb!vm:unwind-block-current-uwp-slot) - (storew cfp-tn block sb!vm:unwind-block-current-cont-slot) - (storew code-tn block sb!vm:unwind-block-current-code-slot) + (inst addi block cfp-tn (* (tn-offset tn) n-word-bytes)) + (load-tl-symbol-value temp *current-unwind-protect-block*) + (storew temp block unwind-block-current-uwp-slot) + (storew cfp-tn block unwind-block-current-cont-slot) + (storew code-tn block unwind-block-current-code-slot) (inst compute-lra-from-code temp code-tn entry-label ndescr) - (storew temp block sb!vm:catch-block-entry-pc-slot))) + (storew temp block catch-block-entry-pc-slot))) ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and @@ -90,25 +95,25 @@ ;;; (define-vop (make-catch-block) (:args (tn) - (tag :scs (any-reg descriptor-reg))) + (tag :scs (any-reg descriptor-reg))) (:info entry-label) (:results (block :scs (any-reg))) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) (:temporary (:scs (non-descriptor-reg)) ndescr) (:generator 44 - (inst addi result cfp-tn (* (tn-offset tn) sb!vm:n-word-bytes)) - (load-symbol-value temp *current-unwind-protect-block*) - (storew temp result sb!vm:catch-block-current-uwp-slot) - (storew cfp-tn result sb!vm:catch-block-current-cont-slot) - (storew code-tn result sb!vm:catch-block-current-code-slot) + (inst addi result cfp-tn (* (tn-offset tn) n-word-bytes)) + (load-tl-symbol-value temp *current-unwind-protect-block*) + (storew temp result catch-block-current-uwp-slot) + (storew cfp-tn result catch-block-current-cont-slot) + (storew code-tn result catch-block-current-code-slot) (inst compute-lra-from-code temp code-tn entry-label ndescr) - (storew temp result sb!vm:catch-block-entry-pc-slot) + (storew temp result catch-block-entry-pc-slot) - (storew tag result sb!vm:catch-block-tag-slot) - (load-symbol-value temp *current-catch-block*) - (storew temp result sb!vm:catch-block-previous-catch-slot) - (store-symbol-value result *current-catch-block*) + (storew tag result catch-block-tag-slot) + (load-tl-symbol-value temp *current-catch-block*) + (storew temp result catch-block-previous-catch-slot) + (store-tl-symbol-value result *current-catch-block* temp) (move block result))) @@ -119,28 +124,31 @@ (define-vop (set-unwind-protect) (:args (tn)) (:temporary (:scs (descriptor-reg)) new-uwp) + #!+sb-thread (:temporary (:scs (any-reg)) temp) (:generator 7 - (inst addi new-uwp cfp-tn (* (tn-offset tn) sb!vm:n-word-bytes)) - (store-symbol-value new-uwp *current-unwind-protect-block*))) + (inst addi new-uwp cfp-tn (* (tn-offset tn) n-word-bytes)) + (store-tl-symbol-value new-uwp *current-unwind-protect-block* temp))) (define-vop (unlink-catch-block) (:temporary (:scs (any-reg)) block) + #!+sb-thread (:temporary (:scs (any-reg)) temp) (:policy :fast-safe) (:translate %catch-breakup) (:generator 17 - (load-symbol-value block *current-catch-block*) - (loadw block block sb!vm:catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) + (load-tl-symbol-value block *current-catch-block*) + (loadw block block catch-block-previous-catch-slot) + (store-tl-symbol-value block *current-catch-block* temp))) (define-vop (unlink-unwind-protect) (:temporary (:scs (any-reg)) block) + #!+sb-thread (:temporary (:scs (any-reg)) temp) (:policy :fast-safe) (:translate %unwind-protect-breakup) (:generator 17 - (load-symbol-value block *current-unwind-protect-block*) - (loadw block block sb!vm:unwind-block-current-uwp-slot) - (store-symbol-value block *current-unwind-protect-block*))) + (load-tl-symbol-value block *current-unwind-protect-block*) + (loadw block block unwind-block-current-uwp-slot) + (store-tl-symbol-value block *current-unwind-protect-block* temp))) ;;;; NLX entry VOPs: @@ -148,9 +156,9 @@ (define-vop (nlx-entry) (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. - (start) - (count)) + ; would be inserted before the LRA. + (start) + (count)) (:results (values :more t)) (:temporary (:scs (descriptor-reg)) move-temp) (:info label nvals) @@ -160,47 +168,47 @@ (emit-return-pc label) (note-this-location vop :non-local-entry) (cond ((zerop nvals)) - ((= nvals 1) - (let ((no-values (gen-label))) - (inst cmpwi count 0) - (move (tn-ref-tn values) null-tn) - (inst beq no-values) - (loadw (tn-ref-tn values) start) - (emit-label no-values))) - (t - (collect ((defaults)) - (inst addic. count count (- (fixnumize 1))) - (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 subi count count (fixnumize 1)) - (inst blt default-lab) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start i)) - (control-stack - (loadw move-temp start i) - (store-stack-tn tn move-temp))) + ((= nvals 1) + (let ((no-values (gen-label))) + (inst cmpwi count 0) + (move (tn-ref-tn values) null-tn) + (inst beq no-values) + (loadw (tn-ref-tn values) start) + (emit-label no-values))) + (t + (collect ((defaults)) + (inst addic. count count (- (fixnumize 1))) + (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 subi count count (fixnumize 1)) + (inst blt default-lab) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start i)) + (control-stack + (loadw move-temp start i) + (store-stack-tn tn move-temp))) (inst cmpwi count 0))) - - (let ((defaulting-done (gen-label))) - - (emit-label defaulting-done) - - (assemble (*elsewhere*) - (dolist (def (defaults)) - (emit-label (car def)) - (let ((tn (cdr def))) - (sc-case tn - ((descriptor-reg any-reg) - (move tn null-tn)) - (control-stack - (store-stack-tn tn null-tn))))) - (inst b defaulting-done)))))) + + (let ((defaulting-done (gen-label))) + + (emit-label defaulting-done) + + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (let ((tn (cdr def))) + (sc-case tn + ((descriptor-reg any-reg) + (move tn null-tn)) + (control-stack + (store-stack-tn tn null-tn))))) + (inst b defaulting-done)))))) (load-stack-tn csp-tn sp))) @@ -212,14 +220,14 @@ (:temporary (:scs (any-reg)) dst) (:temporary (:scs (descriptor-reg)) temp) (:results (result :scs (any-reg) :from (:argument 0)) - (num :scs (any-reg) :from (:argument 0))) + (num :scs (any-reg) :from (:argument 0))) (:save-p :force-to-stack) (:vop-var vop) (:generator 30 (emit-return-pc label) (note-this-location vop :non-local-entry) (let ((loop (gen-label)) - (done (gen-label))) + (done (gen-label))) ;; Setup results, and test for the zero value case. (load-stack-tn result top)