(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
(trace-table-entry trace-table-fun-prologue)
(emit-label start-lab)
;; Allocate function header.
- (inst fun-header-word)
+ (inst simple-fun-header-word)
(dotimes (i (1- simple-fun-code-offset))
(inst word 0))
;; The start of the actual code.
;; Compute CODE from the address of this entry point.
(let ((entry-point (gen-label)))
(emit-label entry-point)
- (inst compute-code-from-fn code-tn lip-tn entry-point temp)
+ (inst compute-code-from-lip code-tn lip-tn entry-point temp)
;; ### We should also save it on the stack so that the garbage collector
;; won't forget about us if we call anyone else.
)
;; 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))))
(when lra-label
(inst compute-code-from-lra code-tn code-tn lra-label temp))
(inst addu csp-tn csp-tn 4)
- (storew (first register-arg-tns) csp-tn -1)
+ (storew (first *register-arg-tns*) csp-tn -1)
(inst addu start csp-tn -4)
(inst li count (fixnumize 1))
(emit-label done)
(assemble (*elsewhere*)
+ (trace-table-entry trace-table-fun-prologue)
(emit-label variable-values)
(when lra-label
(inst compute-code-from-lra code-tn code-tn lra-label temp))
- (do ((arg register-arg-tns (rest arg))
+ (do ((arg *register-arg-tns* (rest arg))
(i 0 (1+ i)))
((null arg))
(storew (first arg) args i))
(move start args)
(inst b done)
- (move count nargs t)))
+ (move count nargs t)
+ (trace-table-entry trace-table-normal)))
(values))
(: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
;; Is this the last one?
(inst beq count done)
;; Store it relative to the pointer saved at the start.
- (storew (nth i register-arg-tns) result (- i fixed))
+ (storew (nth i *register-arg-tns*) result (- i fixed))
;; Decrement count.
(inst subu count (fixnumize 1))))
(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))