X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fcall.lisp;h=d83df06e43b4fc086d9332cf8536d27cfeec5ba4;hb=4e6200853a661da5e73d0843a4afca9077a06fa8;hp=8468f3fb49b70c2149c8b7924c67f5b394be716b;hpb=3a0f3612dc2bbf3e4e8e7395bcbbf8cd1791b963;p=sbcl.git diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index 8468f3f..d83df06 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -618,10 +618,11 @@ default-value-8 ,@(unless (or (eq return :tail) variable) '((:move-args :full-call))) - (:vop-var vop) - (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(nargs)) - ,@(when (eq return :fixed) '(nvals))) + (:vop-var vop) + (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals)) + step-instrumenting) (:ignore ,@(unless (or variable (eq return :tail)) '(arg-locs)) @@ -665,6 +666,8 @@ default-value-8 ,@(when (eq return :fixed) '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) + (:temporary (:scs (descriptor-reg) :to :eval) stepping) + ,@(unless (eq return :tail) '((:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) @@ -677,9 +680,11 @@ default-value-8 15 (if (eq return :unknown) 25 0)) (trace-table-entry trace-table-call-site) + (let* ((cur-nfp (current-nfp-tn vop)) ,@(unless (eq return :tail) '((lra-label (gen-label)))) + (step-done-label (gen-label)) (filler (remove nil (list :load-nargs @@ -741,7 +746,30 @@ default-value-8 '(if (> nargs register-arg-count) (move cfp-tn new-fp) (move cfp-tn csp-tn)))))) - ((nil)))))) + ((nil))))) + (insert-step-instrumenting (callable-tn) + ;; Conditionally insert a conditional trap: + (when step-instrumenting + ;; Get the symbol-value of SB!IMPL::*STEPPING* + (loadw stepping + null-tn + (+ symbol-value-slot + (truncate (static-symbol-offset 'sb!impl::*stepping*) + n-word-bytes)) + other-pointer-lowtag) + (inst cmpw stepping null-tn) + ;; If it's not null, trap. + (inst beq step-done-label) + ;; CONTEXT-PC will be pointing here when the + ;; interrupt is handled, not after the UNIMP. + (note-this-location vop :step-before-vop) + ;; Construct a trap code with the low bits from + ;; SINGLE-STEP-AROUND-TRAP and the high bits from + ;; the register number of CALLABLE-TN. + (inst unimp (logior single-step-around-trap + (ash (reg-tn-encoding callable-tn) + 5))) + (emit-label step-done-label)))) ,@(if named `((sc-case name (descriptor-reg (move name-pass name)) @@ -752,6 +780,10 @@ default-value-8 (loadw name-pass code-tn (tn-offset name) other-pointer-lowtag) (do-next-filler))) + ;; The step instrumenting must be done after + ;; FUNCTION is loaded, but before ENTRY-POINT is + ;; calculated. + (insert-step-instrumenting name-pass) (loadw entry-point name-pass fdefn-raw-addr-slot other-pointer-lowtag) (do-next-filler)) @@ -767,6 +799,10 @@ default-value-8 (loadw function lexenv closure-fun-slot fun-pointer-lowtag) (do-next-filler) + ;; The step instrumenting must be done before + ;; after FUNCTION is loaded, but before ENTRY-POINT + ;; is calculated. + (insert-step-instrumenting function) (inst addi entry-point function (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)) @@ -811,7 +847,6 @@ default-value-8 (define-full-call call-variable nil :fixed t) (define-full-call multiple-call-variable nil :unknown t) - ;;; Defined separately, since needs special code that BLT's the ;;; arguments down. (define-vop (tail-call-variable) @@ -820,33 +855,27 @@ default-value-8 (function-arg :scs (descriptor-reg) :target lexenv) (old-fp-arg :scs (any-reg) :target old-fp) (lra-arg :scs (descriptor-reg) :target lra)) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp) (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) - - + (:temporary (:sc any-reg) temp) (:vop-var vop) - (:generator 75 - ;; Move these into the passing locations if they are not already there. (move args args-arg) (move lexenv function-arg) (move old-fp old-fp-arg) (move lra lra-arg) - - ;; Clear the number stack if anything is there. (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst addi nsp-tn cur-nfp (- (bytes-needed-for-non-descriptor-stack-frame) number-stack-displacement)))) - - - (inst ba (make-fixup 'tail-call-variable :assembly-routine)))) + (inst lr temp (make-fixup 'tail-call-variable :assembly-routine)) + (inst mtlr temp) + (inst blr))) ;;;; Unknown values return: @@ -942,17 +971,14 @@ default-value-8 (lra-arg :scs (descriptor-reg) :to (:eval 1)) (vals-arg :scs (any-reg) :target vals) (nvals-arg :scs (any-reg) :target nvals)) - (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp) (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) (:temporary (:sc descriptor-reg :offset a0-offset) a0) (:temporary (:scs (interior-reg)) lip) - - + (:temporary (:sc any-reg) temp) (:vop-var vop) - (:generator 13 (trace-table-entry trace-table-fun-epilogue) (let ((not-single (gen-label))) @@ -962,24 +988,23 @@ default-value-8 (inst addi nsp-tn cur-nfp (- (bytes-needed-for-non-descriptor-stack-frame) number-stack-displacement)))) - ;; Check for the single case. (inst cmpwi nvals-arg (fixnumize 1)) (inst lwz a0 vals-arg 0) (inst bne not-single) - ;; Return with one value. (move csp-tn cfp-tn) (move cfp-tn old-fp-arg) (lisp-return lra-arg lip :offset 2) - ;; Nope, not the single case. (emit-label not-single) (move old-fp old-fp-arg) (move lra lra-arg) (move vals vals-arg) (move nvals nvals-arg) - (inst ba (make-fixup 'return-multiple :assembly-routine))) + (inst lr temp (make-fixup 'return-multiple :assembly-routine)) + (inst mtlr temp) + (inst blr)) (trace-table-entry trace-table-normal))) ;;;; XEP hackery: @@ -1043,11 +1068,9 @@ default-value-8 (emit-label loop) ;; *--dst = *--src, --count - (inst addi src src (- n-word-bytes)) + (inst lwzu temp src (- n-word-bytes)) (inst addic. count count (- (fixnumize 1))) - (loadw temp src) - (inst addi dst dst (- n-word-bytes)) - (storew temp dst) + (inst stwu temp dst (- n-word-bytes)) (inst bgt loop) (emit-label do-regs) @@ -1200,3 +1223,26 @@ default-value-8 (frob unknown-key-arg-error unknown-key-arg-error sb!c::%unknown-key-arg-error key) (frob nil-fun-returned-error nil-fun-returned-error nil fun)) + +(define-vop (step-instrument-before-vop) + (:temporary (:scs (descriptor-reg)) stepping) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + ;; Get the symbol-value of SB!IMPL::*STEPPING* + (loadw stepping + null-tn + (+ symbol-value-slot + (truncate (static-symbol-offset 'sb!impl::*stepping*) + n-word-bytes)) + other-pointer-lowtag) + (inst cmpw stepping null-tn) + ;; If it's not null, trap. + (inst beq DONE) + ;; CONTEXT-PC will be pointing here when the interrupt is handled, + ;; not after the UNIMP. + (note-this-location vop :step-before-vop) + ;; CALLEE-REGISTER-OFFSET isn't needed for before-traps, so we + ;; can just use a bare SINGLE-STEP-BEFORE-TRAP as the code. + (inst unimp single-step-before-trap) + DONE))