- (assert (not (and variable (eq return :tail))))
- `(define-vop (,name
- ,@(when (eq return :unknown)
- '(unknown-values-receiver)))
- (:args
- ,@(unless (eq return :tail)
- '((new-fp :scs (any-reg) :to (:argument 1))))
-
- (fun :scs (descriptor-reg control-stack)
- :target eax :to (:argument 0))
-
- ,@(when (eq return :tail)
- '((old-fp)
- (return-pc)))
-
- ,@(unless variable '((args :more t :scs (descriptor-reg)))))
-
- ,@(when (eq return :fixed)
- '((:results (values :more t))))
-
- (:save-p ,(if (eq return :tail) :compute-only t))
-
- ,@(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)))
-
- (:ignore
- ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
-
- ;; We pass either the fdefn object (for named call) or the actual
- ;; function object (for unnamed call) in EAX. With named call,
- ;; closure-tramp will replace it with the real function and invoke
- ;; the real function for closures. Non-closures do not need this
- ;; value, so don't care what shows up in it.
- (:temporary
- (:sc descriptor-reg :offset eax-offset :from (:argument 0) :to :eval)
- eax)
-
- ;; We pass the number of arguments in ECX.
- (:temporary (:sc unsigned-reg :offset ecx-offset :to :eval) ecx)
-
- ;; With variable call, we have to load the register-args out
- ;; of the (new) stack frame before doing the call. Therefore,
- ;; we have to tell the lifetime stuff that we need to use them.
- ,@(when variable
- (mapcar #'(lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :from (:argument 0)
- :to :eval)
- ,name))
- *register-arg-names* *register-arg-offsets*))
-
- ,@(when (eq return :tail)
- '((:temporary (:sc unsigned-reg
- :from (:argument 1)
- :to (:argument 2))
- old-fp-tmp)))
-
- (:generator ,(+ (if named 5 0)
- (if variable 19 1)
- (if (eq return :tail) 0 10)
- 15
- (if (eq return :unknown) 25 0))
- (trace-table-entry trace-table-call-site)
-
- ;; This has to be done before the frame pointer is changed!
- ;; eax stores the 'lexical environment' needed for closures
- (move eax fun)
-
-
- ,@(if variable
- ;; For variable call, compute the number of
- ;; arguments and move some of the arguments to
- ;; registers.
- (collect ((noise))
- ;; Compute the number of arguments.
- (noise '(inst mov ecx new-fp))
- (noise '(inst sub ecx esp-tn))
- ;; Move the necessary args to registers,
- ;; this moves them all even if they are
- ;; not all needed.
- (loop
- for name in *register-arg-names*
- for index downfrom -1
- do (noise `(loadw ,name new-fp ,index)))
- (noise))
- '((if (zerop nargs)
- (inst xor ecx ecx)
- (inst mov ecx (fixnumize nargs)))))
- ,@(cond ((eq return :tail)
- '(;; Python has figured out what frame we should
- ;; return to so might as well use that clue.
- ;; This seems really important to the
- ;; implementation of things like
- ;; (without-interrupts ...)
- ;;
- ;; dtc; Could be doing a tail call from a
- ;; known-local-call etc in which the old-fp
- ;; or ret-pc are in regs or in non-standard
- ;; places. If the passing location were
- ;; wired to the stack in standard locations
- ;; then these moves will be un-necessary;
- ;; this is probably best for the x86.
- (sc-case old-fp
- ((control-stack)
- (unless (= ocfp-save-offset
- (tn-offset old-fp))
- ;; FIXME: FORMAT T for stale
- ;; diagnostic output (several of
- ;; them around here), ick
- (format t "** tail-call old-fp not S0~%")
- (move old-fp-tmp old-fp)
- (storew old-fp-tmp
- ebp-tn
- (- (1+ ocfp-save-offset)))))
- ((any-reg descriptor-reg)
- (format t "** tail-call old-fp in reg not S0~%")
- (storew old-fp
- ebp-tn
- (- (1+ ocfp-save-offset)))))
-
- ;; For tail call, we have to push the
- ;; return-pc so that it looks like we CALLed
- ;; despite the fact that we are going to JMP.
- (inst push return-pc)
- ))
- (t
- ;; For non-tail call, we have to save our
- ;; frame pointer and install the new frame
- ;; pointer. We can't load stack tns after this
- ;; point.
- `(;; Python doesn't seem to allocate a frame
- ;; here which doesn't leave room for the
- ;; ofp/ret stuff.
-
- ;; The variable args are on the stack and
- ;; become the frame, but there may be <3
- ;; args and 3 stack slots are assumed
- ;; allocate on the call. So need to ensure
- ;; there are at least 3 slots. This hack
- ;; just adds 3 more.
- ,(if variable
- '(inst sub esp-tn (fixnumize 3)))
-
- ;; Save the fp
- (storew ebp-tn new-fp (- (1+ ocfp-save-offset)))
-
- (move ebp-tn new-fp) ; NB - now on new stack frame.
- )))
-
- (note-this-location vop :call-site)
-
- (inst ,(if (eq return :tail) 'jmp 'call)
- (make-ea :dword :base eax
- :disp ,(if named
- '(- (* fdefn-raw-addr-slot word-bytes)
- other-pointer-type)
- '(- (* closure-function-slot word-bytes)
- function-pointer-type))))
- ,@(ecase return
- (:fixed
- '((default-unknown-values vop values nvals)))
- (:unknown
- '((note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count)))
- (:tail))
- (trace-table-entry trace-table-normal)))))
+ (aver (not (and variable (eq return :tail))))
+ `(define-vop (,name
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
+ (:args
+ ,@(unless (eq return :tail)
+ '((new-fp :scs (any-reg) :to (:argument 1))))
+
+ (fun :scs (descriptor-reg control-stack)
+ :target eax :to (:argument 0))
+
+ ,@(when (eq return :tail)
+ '((old-fp)
+ (return-pc)))
+
+ ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+ ,@(when (eq return :fixed)
+ '((:results (values :more t))))
+
+ (:save-p ,(if (eq return :tail) :compute-only t))
+
+ ,@(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))
+ step-instrumenting)
+
+ (:ignore
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(args)))
+
+ ;; We pass either the fdefn object (for named call) or
+ ;; the actual function object (for unnamed call) in
+ ;; EAX. With named call, closure-tramp will replace it
+ ;; with the real function and invoke the real function
+ ;; for closures. Non-closures do not need this value,
+ ;; so don't care what shows up in it.
+ (:temporary
+ (:sc descriptor-reg
+ :offset eax-offset
+ :from (:argument 0)
+ :to :eval)
+ eax)
+
+ ;; We pass the number of arguments in ECX.
+ (:temporary (:sc unsigned-reg :offset ecx-offset :to :eval) ecx)
+
+ ;; With variable call, we have to load the
+ ;; register-args out of the (new) stack frame before
+ ;; doing the call. Therefore, we have to tell the
+ ;; lifetime stuff that we need to use them.
+ ,@(when variable
+ (mapcar (lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :from (:argument 0)
+ :to :eval)
+ ,name))
+ *register-arg-names* *register-arg-offsets*))
+
+ ,@(when (eq return :tail)
+ '((:temporary (:sc unsigned-reg
+ :from (:argument 1)
+ :to (:argument 2))
+ old-fp-tmp)))
+
+ (:generator ,(+ (if named 5 0)
+ (if variable 19 1)
+ (if (eq return :tail) 0 10)
+ 15
+ (if (eq return :unknown) 25 0))
+ (trace-table-entry trace-table-call-site)
+
+ ;; This has to be done before the frame pointer is
+ ;; changed! EAX stores the 'lexical environment' needed
+ ;; for closures.
+ (move eax fun)
+
+
+ ,@(if variable
+ ;; For variable call, compute the number of
+ ;; arguments and move some of the arguments to
+ ;; registers.
+ (collect ((noise))
+ ;; Compute the number of arguments.
+ (noise '(inst mov ecx new-fp))
+ (noise '(inst sub ecx esp-tn))
+ ;; Move the necessary args to registers,
+ ;; this moves them all even if they are
+ ;; not all needed.
+ (loop
+ for name in *register-arg-names*
+ for index downfrom -1
+ do (noise `(loadw ,name new-fp ,index)))
+ (noise))
+ '((if (zerop nargs)
+ (inst xor ecx ecx)
+ (inst mov ecx (fixnumize nargs)))))
+ ,@(cond ((eq return :tail)
+ '(;; Python has figured out what frame we should
+ ;; return to so might as well use that clue.
+ ;; This seems really important to the
+ ;; implementation of things like
+ ;; (without-interrupts ...)
+ ;;
+ ;; dtc; Could be doing a tail call from a
+ ;; known-local-call etc in which the old-fp
+ ;; or ret-pc are in regs or in non-standard
+ ;; places. If the passing location were
+ ;; wired to the stack in standard locations
+ ;; then these moves will be un-necessary;
+ ;; this is probably best for the x86.
+ (sc-case old-fp
+ ((control-stack)
+ (unless (= ocfp-save-offset
+ (tn-offset old-fp))
+ ;; FIXME: FORMAT T for stale
+ ;; diagnostic output (several of
+ ;; them around here), ick
+ (format t "** tail-call old-fp not S0~%")
+ (move old-fp-tmp old-fp)
+ (storew old-fp-tmp
+ ebp-tn
+ (frame-word-offset ocfp-save-offset))))
+ ((any-reg descriptor-reg)
+ (format t "** tail-call old-fp in reg not S0~%")
+ (storew old-fp
+ ebp-tn
+ (frame-word-offset ocfp-save-offset))))
+
+ ;; For tail call, we have to push the
+ ;; return-pc so that it looks like we CALLed
+ ;; despite the fact that we are going to JMP.
+ (inst push return-pc)
+ ))
+ (t
+ ;; For non-tail call, we have to save our
+ ;; frame pointer and install the new frame
+ ;; pointer. We can't load stack tns after this
+ ;; point.
+ `(;; Python doesn't seem to allocate a frame
+ ;; here which doesn't leave room for the
+ ;; ofp/ret stuff.
+
+ ;; The variable args are on the stack and
+ ;; become the frame, but there may be <3
+ ;; args and 3 stack slots are assumed
+ ;; allocate on the call. So need to ensure
+ ;; there are at least 3 slots. This hack
+ ;; just adds 3 more.
+ ,(if variable
+ '(inst sub esp-tn (fixnumize 3)))
+
+ ;; Save the fp
+ (storew ebp-tn new-fp (frame-word-offset ocfp-save-offset))
+
+ (move ebp-tn new-fp) ; NB - now on new stack frame.
+ )))
+
+ (when step-instrumenting
+ (emit-single-step-test)
+ (inst jmp :eq DONE)
+ (inst break single-step-around-trap))
+ DONE
+
+ (note-this-location vop :call-site)
+
+ (inst ,(if (eq return :tail) 'jmp 'call)
+ ,(if named
+ '(make-ea-for-object-slot eax fdefn-raw-addr-slot
+ other-pointer-lowtag)
+ '(make-ea-for-object-slot eax closure-fun-slot
+ fun-pointer-lowtag)))
+ ,@(ecase return
+ (:fixed
+ '((default-unknown-values vop values nvals)))
+ (:unknown
+ '((note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count)))
+ (:tail))
+ (trace-table-entry trace-table-normal)))))