;;; Return a wired TN describing the N'th full call argument passing
;;; location.
-(!def-vm-support-routine standard-arg-location (n)
+(defun standard-arg-location (n)
(declare (type unsigned-byte n))
(if (< n register-arg-count)
(make-wired-tn *backend-t-primitive-type* register-arg-scn
;;; otherwise use any legal location. Even in the non-standard case,
;;; this may be restricted by a desire to use a subroutine call
;;; instruction.
-(!def-vm-support-routine make-return-pc-passing-location (standard)
+(defun make-return-pc-passing-location (standard)
(if standard
(make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset)
(make-restricted-tn *backend-t-primitive-type* register-arg-scn)))
;;; standard convention, but is totally unrestricted in non-standard
;;; conventions, since we can always fetch it off of the stack using
;;; the arg pointer.
-(!def-vm-support-routine make-old-fp-passing-location (standard)
+(defun make-old-fp-passing-location (standard)
(if standard
(make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
(make-normal-tn *fixnum-primitive-type*)))
;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current
;;; function. We treat these specially so that the debugger can find
;;; them at a known location.
-(!def-vm-support-routine make-old-fp-save-location (env)
+(defun make-old-fp-save-location (env)
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
(make-wired-tn *fixnum-primitive-type*
control-stack-arg-scn
ocfp-save-offset)))
-(!def-vm-support-routine make-return-pc-save-location (env)
+(defun make-return-pc-save-location (env)
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env)
(make-wired-tn *backend-t-primitive-type*
;;; Make a TN for the standard argument count passing location. We
;;; only need to make the standard location, since a count is never
;;; passed when we are using non-standard conventions.
-(!def-vm-support-routine make-arg-count-location ()
+(defun make-arg-count-location ()
(make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
;;; Make a TN to hold the number-stack frame pointer. This is
;;; allocated once per component, and is component-live.
-(!def-vm-support-routine make-nfp-tn ()
+(defun make-nfp-tn ()
(component-live-tn
(make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
-(!def-vm-support-routine make-stack-pointer-tn ()
+(defun make-stack-pointer-tn ()
(make-normal-tn *fixnum-primitive-type*))
-(!def-vm-support-routine make-number-stack-pointer-tn ()
+(defun make-number-stack-pointer-tn ()
(make-normal-tn *fixnum-primitive-type*))
;;; Return a list of TNs that can be used to represent an unknown-values
;;; continuation within a function.
-(!def-vm-support-routine make-unknown-values-locations ()
+(defun make-unknown-values-locations ()
(list (make-stack-pointer-tn)
(make-normal-tn *fixnum-primitive-type*)))
;;; VM-dependent initialization of the IR2-COMPONENT structure. We push
;;; placeholder entries in the Constants to leave room for additional
;;; noise in the code object header.
-(!def-vm-support-routine select-component-format (component)
+(defun select-component-format (component)
(declare (type component component))
(dotimes (i code-constants-offset)
(vector-push-extend nil
(when nfp
(inst addi val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
+;;; Accessing a slot from an earlier stack frame is definite hackery.
+(define-vop (ancestor-frame-ref)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (variable-home-tn :load-if nil))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (sc-is variable-home-tn control-stack))
+ (loadw value frame-pointer (tn-offset variable-home-tn))))
+(define-vop (ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg)))
+ (:results (variable-home-tn :load-if nil))
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (sc-is variable-home-tn control-stack))
+ (storew value frame-pointer (tn-offset variable-home-tn))))
+
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
(:ignore copy-more-arg-follows)
(:generator 1
;; Make sure the function is aligned, and drop a label pointing to this
;; function header.
- (align n-lowtag-bits)
+ (emit-alignment n-lowtag-bits)
(trace-table-entry trace-table-fun-prologue)
(emit-label start-lab)
;; Allocate function header.
(note-this-location vop :single-value-return)
(move csp-tn ocfp-tn)
(inst nop))
- (inst compute-code-from-lra code-tn code-tn lra-label temp))
+ (inst compute-code-from-lra code-tn lra-tn lra-label temp))
(let ((regs-defaulted (gen-label))
(defaulting-done (gen-label))
(default-stack-vals (gen-label)))
(inst b defaulting-done)
(trace-table-entry trace-table-normal))))))
- (inst compute-code-from-lra code-tn code-tn lra-label temp)))
+ (inst compute-code-from-lra code-tn lra-tn lra-label temp)))
(values))
\f
(inst b variable-values)
(inst nop))
- (inst compute-code-from-lra code-tn code-tn lra-label temp)
+ (inst compute-code-from-lra code-tn lra-tn lra-label temp)
(inst addi csp-tn csp-tn 4)
(storew (first *register-arg-tns*) csp-tn -1)
(inst subi start csp-tn 4)
(assemble (*elsewhere*)
(trace-table-entry trace-table-fun-prologue)
(emit-label variable-values)
- (inst compute-code-from-lra code-tn code-tn lra-label temp)
+ (inst compute-code-from-lra code-tn lra-tn lra-label temp)
(do ((arg *register-arg-tns* (rest arg))
(i 0 (1+ i)))
((null arg))
nvals)
(:temporary (:scs (non-descriptor-reg)) temp))
+\f
+;;; This hook in the codegen pass lets us insert code before fall-thru entry
+;;; points, local-call entry points, and tail-call entry points. The default
+;;; does nothing.
+(defun emit-block-header (start-label trampoline-label fall-thru-p alignp)
+ (declare (ignore fall-thru-p alignp))
+ (when trampoline-label
+ (emit-label trampoline-label))
+ (emit-label start-label))
\f
;;;; Local call with unknown values convention return:
,@(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))
(:temporary (:sc descriptor-reg
:offset lra-offset
:from (:argument ,(if (eq return :tail) 2 1))
- :to :eval)
+ :to (:result 0))
return-pc-pass)
,(if named
:from (:argument ,(if (eq return :tail) 0 1))
:to :eval)
lexenv))
- ,@(unless named
- '((:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
- function)))
+ (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
+ function)
(:temporary (:sc any-reg :offset nargs-offset :to :eval)
nargs-pass)
,@(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)))
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
'(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*
+ #!-sb-thread
+ (load-symbol-value stepping sb!impl::*stepping*)
+ #!+sb-thread
+ (loadw stepping thread-base-tn thread-stepping-slot)
+ (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))
(loadw name-pass code-tn (tn-offset name)
other-pointer-lowtag)
(do-next-filler)))
- (loadw entry-point name-pass fdefn-raw-addr-slot
- other-pointer-lowtag)
+ ;; The step instrumenting must be done after
+ ;; FUNCTION is loaded, but before ENTRY-POINT is
+ ;; calculated.
+ (insert-step-instrumenting name-pass)
+ ;; The raw-addr (ENTRY-POINT) will be one of:
+ ;; closure_tramp, undefined_tramp, or somewhere
+ ;; within a simple-fun object. If the latter, then
+ ;; it is essential (due to it being an interior
+ ;; pointer) that the function itself be in a
+ ;; register before the raw-addr is loaded.
+ (sb!assem:without-scheduling ()
+ (loadw function name-pass fdefn-fun-slot
+ other-pointer-lowtag)
+ (loadw entry-point name-pass fdefn-raw-addr-slot
+ other-pointer-lowtag))
(do-next-filler))
`((sc-case arg-fun
(descriptor-reg (move lexenv arg-fun))
(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))
(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)
(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)))
\f
;;;; Unknown values return:
;;; Return a single value using the unknown-values convention.
(define-vop (return-single)
- (:args (old-fp :scs (any-reg))
- (return-pc :scs (descriptor-reg))
+ (:args (old-fp :scs (any-reg) :to :eval)
+ (return-pc :scs (descriptor-reg) :target lra)
(value))
(:ignore value)
+ (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
(:temporary (:scs (interior-reg)) lip)
(:vop-var vop)
(:generator 6
(trace-table-entry trace-table-fun-epilogue)
+ (move lra return-pc)
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(move csp-tn cfp-tn)
(move cfp-tn old-fp)
;; Out of here.
- (lisp-return return-pc lip :offset 2)
+ (lisp-return lra lip :offset 2)
(trace-table-entry trace-table-normal)))
;;; Do unknown-values return of a fixed number of values. The Values are
(define-vop (return)
(:args
(old-fp :scs (any-reg))
- (return-pc :scs (descriptor-reg) :to (:eval 1))
+ (return-pc :scs (descriptor-reg) :to (:eval 1) :target lra)
(values :more t))
(:ignore values)
(:info nvals)
(:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
(:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
(:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
+ (:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 1)) lra)
(:temporary (:sc any-reg :offset nargs-offset) nargs)
(:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
(:temporary (:scs (interior-reg)) lip)
(:vop-var vop)
(:generator 6
(trace-table-entry trace-table-fun-epilogue)
+ (move lra return-pc)
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(move csp-tn cfp-tn)
(move cfp-tn old-fp)
;; Out of here.
- (lisp-return return-pc lip :offset 2))
+ (lisp-return lra lip :offset 2))
(t
;; Establish the values pointer and values count.
(move val-ptr cfp-tn)
(dolist (reg (subseq (list a0 a1 a2 a3) nvals))
(move reg null-tn)))
;; And away we go.
- (lisp-return return-pc lip)))
+ (lisp-return lra lip)))
(trace-table-entry trace-table-normal)))
;;; Do unknown-values return of an arbitrary number of values (passed
(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)
+ (move lra lra-arg)
(let ((not-single (gen-label)))
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(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)))
\f
;;;; XEP hackery:
(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)
(:translate %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)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 1000
- (error-call vop ,error ,@args)))))
+ (error-call vop ',error ,@args)))))
(frob arg-count-error invalid-arg-count-error
sb!c::%arg-count-error nargs)
(frob type-check-error object-not-type-error sb!c::%type-check-error
(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*
+ #!-sb-thread
+ (load-symbol-value stepping sb!impl::*stepping*)
+ #!+sb-thread
+ (loadw stepping thread-base-tn thread-stepping-slot)
+ (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))
projects / sbcl.git / blobdiff