(make-wired-tn *fixnum-primitive-type*
control-stack-arg-scn
ocfp-save-offset)))
+
(!def-vm-support-routine make-return-pc-save-location (env)
(let ((ptype *backend-t-primitive-type*))
(specify-save-tn
;; gets confused.
(without-scheduling ()
(note-this-location vop :single-value-return)
- (inst move csp-tn ocfp-tn)
+ (move csp-tn ocfp-tn t)
(inst nop))
(when lra-label
(inst compute-code-from-lra code-tn code-tn lra-label temp)))
(aver defaults)
(assemble (*elsewhere*)
(emit-label default-stack-vals)
+ (trace-table-entry trace-table-fun-prologue)
(do ((remaining defaults (cdr remaining)))
((null remaining))
(let ((def (car remaining)))
(emit-label (car def))
(when (null (cdr remaining))
(inst b defaulting-done))
- (store-stack-tn (cdr def) null-tn)))))))
+ (store-stack-tn (cdr def) null-tn)))
+ (trace-table-entry trace-table-normal)))))
(when lra-label
(inst compute-code-from-lra code-tn code-tn lra-label temp))))
(:ignore args save)
(:vop-var vop)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp)
(:generator 20
(let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(when (eq return :fixed) '(nvals))
+ step-instrumenting)
(:ignore ,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(args)))
,@(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)))
(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
(move cfp-tn csp-tn)))
(trace-table-entry trace-table-call-site))))
((nil)
- (inst nop))))))
+ (inst nop)))))
+ (insert-step-instrumenting (callable-tn)
+ ;; Conditionally insert a conditional trap:
+ (when step-instrumenting
+ ;; Get the symbol-value of SB!IMPL::*STEPPING*
+ (inst lw stepping null-tn
+ (- (+ symbol-value-slot
+ (truncate (static-symbol-offset 'sb!impl::*stepping*)
+ n-word-bytes))
+ other-pointer-lowtag))
+ ;; If it's not NIL, trap.
+ (inst beq stepping null-tn step-done-label)
+ (inst nop)
+ ;; CONTEXT-PC will be pointing here when the
+ ;; interrupt is handled, not after the BREAK.
+ (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 break 0 (logior single-step-around-trap
+ (ash (reg-tn-encoding callable-tn)
+ 5)))
+ (emit-label step-done-label))))
,@(if named
`((sc-case name
(- (ash (tn-offset name) word-shift)
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)
(inst lw entry-point name-pass
(- (ash fdefn-raw-addr-slot word-shift)
other-pointer-lowtag))
(- (ash closure-fun-slot word-shift)
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 addu entry-point function
(- (ash simple-fun-code-offset word-shift)
fun-pointer-lowtag))))
(when cur-nfp
(inst addu nsp-tn cur-nfp
(bytes-needed-for-non-descriptor-stack-frame))))
- ;; Establish the values pointer and values count.
- (move val-ptr cfp-tn)
- (inst li nargs (fixnumize nvals))
- ;; restore the frame pointer and clear as much of the control
- ;; stack as possible.
- (move cfp-tn ocfp)
- (inst addu csp-tn val-ptr (* nvals n-word-bytes))
- ;; pre-default any argument register that need it.
- (when (< nvals register-arg-count)
- (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
- (move reg null-tn)))
- ;; And away we go.
- (lisp-return return-pc lip)
+ (cond ((= nvals 1)
+ ;; Clear the control stack, and restore the frame pointer.
+ (move csp-tn cfp-tn)
+ (move cfp-tn ocfp)
+ ;; Out of here.
+ (lisp-return return-pc lip :offset 2))
+ (t
+ ;; Establish the values pointer and values count.
+ (move val-ptr cfp-tn)
+ (inst li nargs (fixnumize nvals))
+ ;; restore the frame pointer and clear as much of the control
+ ;; stack as possible.
+ (move cfp-tn ocfp)
+ (inst addu csp-tn val-ptr (* nvals n-word-bytes))
+ ;; pre-default any argument register that need it.
+ (when (< nvals register-arg-count)
+ (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
+ (move reg null-tn)))
+ ;; And away we go.
+ (lisp-return return-pc lip)))
(trace-table-entry trace-table-normal)))
;;; Do unknown-values return of an arbitrary number of values (passed on the
(emit-label done))))
-;;; More args are stored consequtively on the stack, starting immediately at
-;;; the context pointer. The context pointer is not typed, so the lowtag is 0.
-;;;
+;;; More args are stored consecutively on the stack, starting
+;;; immediately at the context pointer. The context pointer is not
+;;; typed, so the lowtag is 0.
(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
-
;;; Turn more arg (context, count) into a list.
-;;;
+(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args))
+ t)
+
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:translate %listify-rest-args)
(:policy :safe)
+ (:node-var node)
(:generator 20
- (let ((enter (gen-label))
- (loop (gen-label))
- (done (gen-label)))
+ (let* ((enter (gen-label))
+ (loop (gen-label))
+ (done (gen-label))
+ (dx-p (node-stack-allocate-p node))
+ (alloc-area-tn (if dx-p csp-tn alloc-tn)))
(move context context-arg)
(move count count-arg)
;; Check to see if there are any arguments.
;; We need to do this atomically.
(pseudo-atomic (pa-flag)
+ (when dx-p
+ (align-csp temp))
;; Allocate a cons (2 words) for each item.
- (inst or result alloc-tn list-pointer-lowtag)
+ (inst srl result alloc-area-tn n-lowtag-bits)
+ (inst sll result n-lowtag-bits)
+ (inst or result list-pointer-lowtag)
(move dst result)
(inst sll temp count 1)
(inst b enter)
- (inst addu alloc-tn alloc-tn temp)
+ (inst addu alloc-area-tn temp)
;; Store the current cons in the cdr of the previous cons.
(emit-label loop)
(emit-label enter)
;; Grab one value.
(loadw temp context)
- (inst addu context context n-word-bytes)
+ (inst addu context n-word-bytes)
;; Dec count, and if != zero, go back for more.
(inst addu count count (fixnumize -1))
(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))
+
+;;; Single-stepping
+
+(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*
+ (inst lw stepping null-tn
+ (- (+ symbol-value-slot
+ (truncate (static-symbol-offset 'sb!impl::*stepping*)
+ n-word-bytes))
+ other-pointer-lowtag))
+ ;; If it's not NIL, trap.
+ (inst beq stepping null-tn DONE)
+ (inst nop)
+ ;; CONTEXT-PC will be pointing here when the interrupt is handled,
+ ;; not after the BREAK.
+ (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 break 0 single-step-before-trap)
+ DONE))
projects / sbcl.git / blobdiff