X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fcall.lisp;h=bc1e06ed6d03a4f7607b7735ab6b84db606790ca;hb=08917ec0d00a781a1089922a5419b7f136cdf08f;hp=a2b3302c638df79abc128779e557a65259ff5871;hpb=293a1e0c0ccf62107844f010a8cf9b906cc76492;p=sbcl.git

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp
index a2b3302..bc1e06e 100644
--- a/src/compiler/x86/call.lisp
+++ b/src/compiler/x86/call.lisp
@@ -143,7 +143,8 @@
       (inst lea esp-tn
             (make-ea :dword :base ebp-tn
                      :disp (- (* n-word-bytes
-                                 (max 3 (sb-allocated-size 'stack)))))))
+                                 (- (max 3 (sb-allocated-size 'stack))
+                                    sp->fp-offset))))))
 
     (trace-table-entry trace-table-normal)))
 
@@ -151,12 +152,13 @@
 ;;; or a multiple-call-local. All it does is allocate stack space for the
 ;;; callee (who has the same size stack as us).
 (define-vop (allocate-frame)
-  (:results (res :scs (any-reg control-stack))
+  (:results (res :scs (any-reg))
             (nfp))
   (:info callee)
   (:ignore nfp callee)
   (:generator 2
-    (move res esp-tn)
+    (inst lea res (make-ea :dword :base esp-tn
+                           :disp (- (* sp->fp-offset n-word-bytes))))
     (inst sub esp-tn (* n-word-bytes (sb-allocated-size 'stack)))))
 
 ;;; Allocate a partial frame for passing stack arguments in a full
@@ -165,9 +167,10 @@
 ;;; before it can extend the stack.
 (define-vop (allocate-full-call-frame)
   (:info nargs)
-  (:results (res :scs (any-reg control-stack)))
+  (:results (res :scs (any-reg)))
   (:generator 2
-    (move res esp-tn)
+    (inst lea res (make-ea :dword :base esp-tn
+                           :disp (- (* sp->fp-offset n-word-bytes))))
     (inst sub esp-tn (* (max nargs 3) n-word-bytes))))
 
 ;;; Emit code needed at the return-point from an unknown-values call
@@ -188,178 +191,195 @@
 ;;;     there are stack values.
 ;;;  -- Reset SP. This must be done whenever other than 1 value is
 ;;;     returned, regardless of the number of values desired.
-(defun default-unknown-values (vop values nvals)
+(defun default-unknown-values (vop values nvals node)
   (declare (type (or tn-ref null) values)
            (type unsigned-byte nvals))
-  (cond
-   ((<= nvals 1)
-    (note-this-location vop :single-value-return)
+  (let ((type (sb!c::basic-combination-derived-type node)))
     (cond
-      ((member :cmov *backend-subfeatures*)
-       (inst cmov :c esp-tn ebx-tn))
+      ((<= nvals 1)
+       (note-this-location vop :single-value-return)
+       (cond
+         ((<= (sb!kernel:values-type-max-value-count type)
+              register-arg-count)
+          (when (and (named-type-p type)
+                     (eq nil (named-type-name type)))
+            ;; The function never returns, it may happen that the code
+            ;; ends right here leavig the :SINGLE-VALUE-RETURN note
+            ;; dangling. Let's emit a NOP.
+            (inst nop)))
+         ((not (sb!kernel:values-type-may-be-single-value-p type))
+          (inst mov esp-tn ebx-tn))
+         ((member :cmov *backend-subfeatures*)
+          (inst cmov :c esp-tn ebx-tn))
+         (t
+          (let ((single-value (gen-label)))
+            (inst jmp :nc single-value)
+            (inst mov esp-tn ebx-tn)
+            (emit-label single-value)))))
+      ((<= nvals register-arg-count)
+       (note-this-location vop :unknown-return)
+       (when (sb!kernel:values-type-may-be-single-value-p type)
+         (let ((regs-defaulted (gen-label)))
+           (inst jmp :c regs-defaulted)
+           ;; Default the unsupplied registers.
+           (let* ((2nd-tn-ref (tn-ref-across values))
+                  (2nd-tn (tn-ref-tn 2nd-tn-ref)))
+             (inst mov 2nd-tn nil-value)
+             (when (> nvals 2)
+               (loop
+                for tn-ref = (tn-ref-across 2nd-tn-ref)
+                then (tn-ref-across tn-ref)
+                for count from 2 below register-arg-count
+                do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
+           (inst mov ebx-tn esp-tn)
+           (emit-label regs-defaulted)))
+       (when (< register-arg-count
+                (sb!kernel:values-type-max-value-count type))
+         (inst mov esp-tn ebx-tn)))
+      ((<= nvals 7)
+       ;; The number of bytes depends on the relative jump instructions.
+       ;; Best case is 31+(n-3)*14, worst case is 35+(n-3)*18. For
+       ;; NVALS=6 that is 73/89 bytes, and for NVALS=7 that is 87/107
+       ;; bytes which is likely better than using the blt below.
+       (let ((regs-defaulted (gen-label))
+             (defaulting-done (gen-label))
+             (default-stack-slots (gen-label)))
+         (note-this-location vop :unknown-return)
+         ;; Branch off to the MV case.
+         (inst jmp :c regs-defaulted)
+         ;; Do the single value case.
+         ;; Default the register args
+         (inst mov eax-tn nil-value)
+         (do ((i 1 (1+ i))
+              (val (tn-ref-across values) (tn-ref-across val)))
+             ((= i (min nvals register-arg-count)))
+           (inst mov (tn-ref-tn val) eax-tn))
+         ;; Fake other registers so it looks like we returned with all the
+         ;; registers filled in.
+         (move ebx-tn esp-tn)
+         (inst jmp default-stack-slots)
+         (emit-label regs-defaulted)
+         (inst mov eax-tn nil-value)
+         (collect ((defaults))
+           (do ((i register-arg-count (1+ i))
+                (val (do ((i 0 (1+ i))
+                          (val values (tn-ref-across val)))
+                         ((= i register-arg-count) val))
+                     (tn-ref-across val)))
+               ((null val))
+             (let ((default-lab (gen-label))
+                   (tn (tn-ref-tn val))
+                   (first-stack-arg-p (= i register-arg-count)))
+               (defaults (cons default-lab
+                               (cons tn first-stack-arg-p)))
+               (inst cmp ecx-tn (fixnumize i))
+               (inst jmp :be default-lab)
+               (when first-stack-arg-p
+                 ;; There are stack args so the frame of the callee is
+                 ;; still there, save EDX in its first slot temporalily.
+                 (storew edx-tn ebx-tn (frame-word-offset sp->fp-offset)))
+               (loadw edx-tn ebx-tn (frame-word-offset (+ sp->fp-offset i)))
+               (inst mov tn edx-tn)))
+           (emit-label defaulting-done)
+           (loadw edx-tn ebx-tn (frame-word-offset sp->fp-offset))
+           (move esp-tn ebx-tn)
+           (let ((defaults (defaults)))
+             (when defaults
+               (assemble (*elsewhere*)
+                 (trace-table-entry trace-table-fun-prologue)
+                 (emit-label default-stack-slots)
+                 (dolist (default defaults)
+                   (emit-label (car default))
+                   (when (cddr default)
+                     ;; We are setting the first stack argument to NIL.
+                     ;; The callee's stack frame is dead, save EDX by
+                     ;; pushing it to the stack, it will end up at same
+                     ;; place as in the (STOREW EDX-TN EBX-TN -1) case
+                     ;; above.
+                     (inst push edx-tn))
+                   (inst mov (second default) eax-tn))
+                 (inst jmp defaulting-done)
+                 (trace-table-entry trace-table-normal)))))))
       (t
-       (let ((single-value (gen-label)))
-         (inst jmp :nc single-value)
+       ;; 91 bytes for this branch.
+       (let ((regs-defaulted (gen-label))
+             (restore-edi (gen-label))
+             (no-stack-args (gen-label))
+             (default-stack-vals (gen-label))
+             (count-okay (gen-label)))
+         (note-this-location vop :unknown-return)
+         ;; Branch off to the MV case.
+         (inst jmp :c regs-defaulted)
+         ;; Default the register args, and set up the stack as if we
+         ;; entered the MV return point.
+         (inst mov ebx-tn esp-tn)
+         (inst mov edi-tn nil-value)
+         (inst mov esi-tn edi-tn)
+         ;; Compute a pointer to where to put the [defaulted] stack values.
+         (emit-label no-stack-args)
+         (inst push edx-tn)
+         (inst push edi-tn)
+         (inst lea edi-tn
+               (make-ea :dword :base ebp-tn
+                        :disp (frame-byte-offset register-arg-count)))
+         ;; Load EAX with NIL so we can quickly store it, and set up
+         ;; stuff for the loop.
+         (inst mov eax-tn nil-value)
+         (inst std)
+         (inst mov ecx-tn (- nvals register-arg-count))
+         ;; Jump into the default loop.
+         (inst jmp default-stack-vals)
+         ;; The regs are defaulted. We need to copy any stack arguments,
+         ;; and then default the remaining stack arguments.
+         (emit-label regs-defaulted)
+         ;; Compute the number of stack arguments, and if it's zero or
+         ;; less, don't copy any stack arguments.
+         (inst sub ecx-tn (fixnumize register-arg-count))
+         (inst jmp :le no-stack-args)
+         ;; Save EDI.
+         (storew edi-tn ebx-tn (frame-word-offset (+ sp->fp-offset 1)))
+         ;; Throw away any unwanted args.
+         (inst cmp ecx-tn (fixnumize (- nvals register-arg-count)))
+         (inst jmp :be count-okay)
+         (inst mov ecx-tn (fixnumize (- nvals register-arg-count)))
+         (emit-label count-okay)
+         ;; Save the number of stack values.
+         (inst mov eax-tn ecx-tn)
+         ;; Compute a pointer to where the stack args go.
+         (inst lea edi-tn
+               (make-ea :dword :base ebp-tn
+                        :disp (frame-byte-offset register-arg-count)))
+         ;; Save ESI, and compute a pointer to where the args come from.
+         (storew esi-tn ebx-tn (frame-word-offset (+ sp->fp-offset 2)))
+         (inst lea esi-tn
+               (make-ea :dword :base ebx-tn
+                        :disp (frame-byte-offset
+                               (+ sp->fp-offset register-arg-count))))
+         ;; Do the copy.
+         (inst shr ecx-tn word-shift)   ; make word count
+         (inst std)
+         (inst rep)
+         (inst movs :dword)
+         ;; Restore ESI.
+         (loadw esi-tn ebx-tn (frame-word-offset (+ sp->fp-offset 2)))
+         ;; Now we have to default the remaining args. Find out how many.
+         (inst sub eax-tn (fixnumize (- nvals register-arg-count)))
+         (inst neg eax-tn)
+         ;; If none, then just blow out of here.
+         (inst jmp :le restore-edi)
+         (inst mov ecx-tn eax-tn)
+         (inst shr ecx-tn word-shift)   ; word count
+         ;; Load EAX with NIL for fast storing.
+         (inst mov eax-tn nil-value)
+         ;; Do the store.
+         (emit-label default-stack-vals)
+         (inst rep)
+         (inst stos eax-tn)
+         ;; Restore EDI, and reset the stack.
+         (emit-label restore-edi)
+         (loadw edi-tn ebx-tn (frame-word-offset (+ sp->fp-offset 1)))
          (inst mov esp-tn ebx-tn)
-         (emit-label single-value)))))
-   ((<= nvals register-arg-count)
-    (let ((regs-defaulted (gen-label)))
-      (note-this-location vop :unknown-return)
-      (inst jmp :c regs-defaulted)
-      ;; Default the unsupplied registers.
-      (let* ((2nd-tn-ref (tn-ref-across values))
-             (2nd-tn (tn-ref-tn 2nd-tn-ref)))
-        (inst mov 2nd-tn nil-value)
-        (when (> nvals 2)
-          (loop
-            for tn-ref = (tn-ref-across 2nd-tn-ref)
-            then (tn-ref-across tn-ref)
-            for count from 2 below register-arg-count
-            do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
-      (inst mov ebx-tn esp-tn)
-      (emit-label regs-defaulted)
-      (inst mov esp-tn ebx-tn)))
-   ((<= nvals 7)
-    ;; The number of bytes depends on the relative jump instructions.
-    ;; Best case is 31+(n-3)*14, worst case is 35+(n-3)*18. For
-    ;; NVALS=6 that is 73/89 bytes, and for NVALS=7 that is 87/107
-    ;; bytes which is likely better than using the blt below.
-    (let ((regs-defaulted (gen-label))
-          (defaulting-done (gen-label))
-          (default-stack-slots (gen-label)))
-      (note-this-location vop :unknown-return)
-      ;; Branch off to the MV case.
-      (inst jmp :c regs-defaulted)
-      ;; Do the single value case.
-      ;; Default the register args
-      (inst mov eax-tn nil-value)
-      (do ((i 1 (1+ i))
-           (val (tn-ref-across values) (tn-ref-across val)))
-          ((= i (min nvals register-arg-count)))
-        (inst mov (tn-ref-tn val) eax-tn))
-
-      ;; Fake other registers so it looks like we returned with all the
-      ;; registers filled in.
-      (move ebx-tn esp-tn)
-      (inst push edx-tn)
-      (inst jmp default-stack-slots)
-
-      (emit-label regs-defaulted)
-
-      (inst mov eax-tn nil-value)
-      (storew edx-tn ebx-tn -1)
-      (collect ((defaults))
-        (do ((i register-arg-count (1+ i))
-             (val (do ((i 0 (1+ i))
-                       (val values (tn-ref-across val)))
-                      ((= i register-arg-count) val))
-                  (tn-ref-across val)))
-            ((null val))
-          (let ((default-lab (gen-label))
-                (tn (tn-ref-tn val)))
-            (defaults (cons default-lab tn))
-
-            (inst cmp ecx-tn (fixnumize i))
-            (inst jmp :be default-lab)
-            (loadw edx-tn ebx-tn (frame-word-offset i))
-            (inst mov tn edx-tn)))
-
-        (emit-label defaulting-done)
-        (loadw edx-tn ebx-tn -1)
-        (move esp-tn ebx-tn)
-
-        (let ((defaults (defaults)))
-          (when defaults
-            (assemble (*elsewhere*)
-              (trace-table-entry trace-table-fun-prologue)
-              (emit-label default-stack-slots)
-              (dolist (default defaults)
-                (emit-label (car default))
-                (inst mov (cdr default) eax-tn))
-              (inst jmp defaulting-done)
-              (trace-table-entry trace-table-normal)))))))
-   (t
-    ;; 91 bytes for this branch.
-    (let ((regs-defaulted (gen-label))
-          (restore-edi (gen-label))
-          (no-stack-args (gen-label))
-          (default-stack-vals (gen-label))
-          (count-okay (gen-label)))
-      (note-this-location vop :unknown-return)
-      ;; Branch off to the MV case.
-      (inst jmp :c regs-defaulted)
-
-      ;; Default the register args, and set up the stack as if we
-      ;; entered the MV return point.
-      (inst mov ebx-tn esp-tn)
-      (inst push edx-tn)
-      (inst mov edi-tn nil-value)
-      (inst push edi-tn)
-      (inst mov esi-tn edi-tn)
-      ;; Compute a pointer to where to put the [defaulted] stack values.
-      (emit-label no-stack-args)
-      (inst lea edi-tn
-            (make-ea :dword :base ebp-tn
-                     :disp (frame-byte-offset register-arg-count)))
-      ;; Load EAX with NIL so we can quickly store it, and set up
-      ;; stuff for the loop.
-      (inst mov eax-tn nil-value)
-      (inst std)
-      (inst mov ecx-tn (- nvals register-arg-count))
-      ;; Jump into the default loop.
-      (inst jmp default-stack-vals)
-
-      ;; The regs are defaulted. We need to copy any stack arguments,
-      ;; and then default the remaining stack arguments.
-      (emit-label regs-defaulted)
-      ;; Save EDI.
-      (storew edi-tn ebx-tn (frame-word-offset 1))
-      ;; Compute the number of stack arguments, and if it's zero or
-      ;; less, don't copy any stack arguments.
-      (inst sub ecx-tn (fixnumize register-arg-count))
-      (inst jmp :le no-stack-args)
-
-      ;; Throw away any unwanted args.
-      (inst cmp ecx-tn (fixnumize (- nvals register-arg-count)))
-      (inst jmp :be count-okay)
-      (inst mov ecx-tn (fixnumize (- nvals register-arg-count)))
-      (emit-label count-okay)
-      ;; Save the number of stack values.
-      (inst mov eax-tn ecx-tn)
-      ;; Compute a pointer to where the stack args go.
-      (inst lea edi-tn
-            (make-ea :dword :base ebp-tn
-                     :disp (frame-byte-offset register-arg-count)))
-      ;; Save ESI, and compute a pointer to where the args come from.
-      (storew esi-tn ebx-tn (frame-word-offset 2))
-      (inst lea esi-tn
-            (make-ea :dword :base ebx-tn
-                     :disp (frame-byte-offset register-arg-count)))
-      ;; Do the copy.
-      (inst shr ecx-tn word-shift)              ; make word count
-      (inst std)
-      (inst rep)
-      (inst movs :dword)
-      ;; Restore ESI.
-      (loadw esi-tn ebx-tn (frame-word-offset 2))
-      ;; Now we have to default the remaining args. Find out how many.
-      (inst sub eax-tn (fixnumize (- nvals register-arg-count)))
-      (inst neg eax-tn)
-      ;; If none, then just blow out of here.
-      (inst jmp :le restore-edi)
-      (inst mov ecx-tn eax-tn)
-      (inst shr ecx-tn word-shift)      ; word count
-      ;; Load EAX with NIL for fast storing.
-      (inst mov eax-tn nil-value)
-      ;; Do the store.
-      (emit-label default-stack-vals)
-      (inst rep)
-      (inst stos eax-tn)
-      ;; Restore EDI, and reset the stack.
-      (emit-label restore-edi)
-      (loadw edi-tn ebx-tn (frame-word-offset 1))
-      (inst mov esp-tn ebx-tn)
-      (inst cld))))
+         (inst cld)))))
   (values))
 
 ;;;; unknown values receiving
@@ -381,27 +401,37 @@
 ;;; explicitly allocate these TNs, since their lifetimes overlap with
 ;;; the results start and count. (Also, it's nice to be able to target
 ;;; them.)
-(defun receive-unknown-values (args nargs start count)
+(defun receive-unknown-values (args nargs start count node)
   (declare (type tn args nargs start count))
-  (let ((variable-values (gen-label))
+  (let ((type (sb!c::basic-combination-derived-type node))
+        (variable-values (gen-label))
+        (stack-values (gen-label))
         (done (gen-label)))
-    (inst jmp :c variable-values)
-
-    (cond ((location= start (first *register-arg-tns*))
-           (inst push (first *register-arg-tns*))
-           (inst lea start (make-ea :dword :base esp-tn :disp n-word-bytes)))
-          (t (inst mov start esp-tn)
-             (inst push (first *register-arg-tns*))))
-    (inst mov count (fixnumize 1))
-    (inst jmp done)
-
-    (emit-label variable-values)
+    (when (sb!kernel:values-type-may-be-single-value-p type)
+      (inst jmp :c variable-values)
+      (cond ((location= start (first *register-arg-tns*))
+             (inst push (first *register-arg-tns*))
+             (inst lea start (make-ea :dword :base esp-tn :disp n-word-bytes)))
+            (t (inst mov start esp-tn)
+               (inst push (first *register-arg-tns*))))
+      (inst mov count (fixnumize 1))
+      (inst jmp done)
+      (emit-label variable-values))
+    ;; The stack frame is burnt and RETurned from if there are no
+    ;; stack values. In this case quickly reallocate sufficient space.
+    (when (<= (sb!kernel:values-type-min-value-count type)
+              register-arg-count)
+      (inst cmp nargs (fixnumize register-arg-count))
+      (inst jmp :g stack-values)
+      (inst sub esp-tn nargs)
+      (emit-label stack-values))
     ;; dtc: this writes the registers onto the stack even if they are
     ;; not needed, only the number specified in ecx are used and have
     ;; stack allocated to them. No harm is done.
     (loop
       for arg in *register-arg-tns*
       for i downfrom -1
+      for j below (sb!kernel:values-type-max-value-count type)
       do (storew arg args i))
     (move start args)
     (move count nargs)
@@ -440,6 +470,17 @@
                (= (tn-offset return-pc) return-pc-save-offset))
     (error "return-pc not on stack in standard save location?")))
 
+;;; Instead of JMPing to TARGET, CALL a trampoline that saves the
+;;; return pc and jumps. Although this is an incredibly stupid trick
+;;; the paired CALL/RET instructions are a big win.
+(defun make-local-call (target)
+  (let ((tramp (gen-label)))
+    (inst call tramp)
+    (assemble (*elsewhere*)
+      (emit-label tramp)
+      (popw ebp-tn (frame-word-offset return-pc-save-offset))
+      (inst jmp target))))
+
 ;;; Non-TR local call for a fixed number of values passed according to
 ;;; the unknown values convention.
 ;;;
@@ -468,33 +509,14 @@
   (:move-args :local-call)
   (:info arg-locs callee target nvals)
   (:vop-var vop)
-  (:ignore nfp arg-locs args #+nil callee)
+  (:ignore nfp arg-locs args callee)
+  (:node-var node)
   (:generator 5
     (trace-table-entry trace-table-call-site)
     (move ebp-tn fp)
-
-    (let ((ret-tn (callee-return-pc-tn callee)))
-      #+nil
-      (format t "*call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
-              ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
-              (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
-
-      ;; Is the return-pc on the stack or in a register?
-      (sc-case ret-tn
-        ((sap-stack)
-         (unless (= (tn-offset ret-tn) return-pc-save-offset)
-           (error "ret-tn ~A in wrong stack slot" ret-tn))
-         #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
-                       (tn-offset ret-tn))
-         (storew (make-fixup nil :code-object RETURN)
-                 ebp-tn (frame-word-offset (tn-offset ret-tn))))
-        (t
-         (error "ret-tn ~A in sap-reg" ret-tn))))
-
     (note-this-location vop :call-site)
-    (inst jmp target)
-    RETURN
-    (default-unknown-values vop values nvals)
+    (make-local-call target)
+    (default-unknown-values vop values nvals node)
     (trace-table-entry trace-table-normal)))
 
 ;;; Non-TR local call for a variable number of return values passed according
@@ -507,34 +529,16 @@
   (:save-p t)
   (:move-args :local-call)
   (:info save callee target)
-  (:ignore args save nfp #+nil callee)
+  (:ignore args save nfp callee)
   (:vop-var vop)
+  (:node-var node)
   (:generator 20
     (trace-table-entry trace-table-call-site)
     (move ebp-tn fp)
-
-    (let ((ret-tn (callee-return-pc-tn callee)))
-      #+nil
-      (format t "*multiple-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
-              ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
-              (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
-
-      ;; Is the return-pc on the stack or in a register?
-      (sc-case ret-tn
-        ((sap-stack)
-         #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
-                       (tn-offset ret-tn))
-         ;; Stack
-         (storew (make-fixup nil :code-object RETURN)
-                 ebp-tn (frame-word-offset (tn-offset ret-tn))))
-        (t
-         (error "multiple-call-local: return-pc not on stack."))))
-
     (note-this-location vop :call-site)
-    (inst jmp target)
-    RETURN
+    (make-local-call target)
     (note-this-location vop :unknown-return)
-    (receive-unknown-values values-start nvals start count)
+    (receive-unknown-values values-start nvals start count node)
     (trace-table-entry trace-table-normal)))
 
 ;;;; local call with known values return
@@ -553,33 +557,13 @@
   (:move-args :local-call)
   (:save-p t)
   (:info save callee target)
-  (:ignore args res save nfp #+nil callee)
+  (:ignore args res save nfp callee)
   (:vop-var vop)
   (:generator 5
     (trace-table-entry trace-table-call-site)
     (move ebp-tn fp)
-
-    (let ((ret-tn (callee-return-pc-tn callee)))
-
-      #+nil
-      (format t "*known-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
-              ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
-              (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
-
-      ;; Is the return-pc on the stack or in a register?
-      (sc-case ret-tn
-        ((sap-stack)
-         #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
-                       (tn-offset ret-tn))
-         ;; Stack
-         (storew (make-fixup nil :code-object RETURN)
-                 ebp-tn (frame-word-offset (tn-offset ret-tn))))
-        (t
-         (error "known-call-local: return-pc not on stack."))))
-
     (note-this-location vop :call-site)
-    (inst jmp target)
-    RETURN
+    (make-local-call target)
     (note-this-location vop :known-return)
     (trace-table-entry trace-table-normal)))
 
@@ -599,9 +583,7 @@
     (check-ocfp-and-return-pc old-fp return-pc)
     (trace-table-entry trace-table-fun-epilogue)
     ;; Zot all of the stack except for the old-fp and return-pc.
-    (inst lea esp-tn
-          (make-ea :dword :base ebp-tn
-                   :disp (frame-byte-offset ocfp-save-offset)))
+    (inst mov esp-tn ebp-tn)
     (inst pop ebp-tn)
     (inst ret)
     (trace-table-entry trace-table-normal)))
@@ -715,6 +697,8 @@
                                       :from (:argument 1)
                                       :to (:argument 2))
                                  old-fp-tmp)))
+               ,@(unless (eq return :tail)
+                   '((:node-var node)))
 
                (:generator ,(+ (if named 5 0)
                                (if variable 19 1)
@@ -803,6 +787,10 @@
                           ,(if variable
                                '(inst sub esp-tn (fixnumize 3)))
 
+                          ;; Bias the new-fp for use as an fp
+                          ,(if variable
+                               '(inst sub new-fp (fixnumize sp->fp-offset)))
+
                           ;; Save the fp
                           (storew ebp-tn new-fp
                                   (frame-word-offset ocfp-save-offset))
@@ -826,10 +814,11 @@
                                                     fun-pointer-lowtag)))
                ,@(ecase return
                    (:fixed
-                    '((default-unknown-values vop values nvals)))
+                    '((default-unknown-values vop values nvals node)))
                    (:unknown
                     '((note-this-location vop :unknown-return)
-                      (receive-unknown-values values-start nvals start count)))
+                      (receive-unknown-values values-start nvals start count
+                                              node)))
                    (:tail))
                (trace-table-entry trace-table-normal)))))
 
@@ -881,13 +870,12 @@
     (check-ocfp-and-return-pc old-fp return-pc)
     (trace-table-entry trace-table-fun-epilogue)
     ;; Drop stack above old-fp
-    (inst lea esp-tn (make-ea :dword :base ebp-tn
-                              :disp (frame-byte-offset (tn-offset old-fp))))
+    (inst mov esp-tn ebp-tn)
     ;; Clear the multiple-value return flag
     (inst clc)
     ;; Restore the old frame pointer
     (inst pop ebp-tn)
-    ;; And return, dropping the rest of the stack as we go.
+    ;; And return.
     (inst ret)))
 
 ;;; Do unknown-values return of a fixed (other than 1) number of
@@ -919,20 +907,16 @@
 
   (:generator 6
     (check-ocfp-and-return-pc old-fp return-pc)
+    (when (= nvals 1)
+      ;; This is handled in RETURN-SINGLE.
+      (error "nvalues is 1"))
     (trace-table-entry trace-table-fun-epilogue)
     ;; Establish the values pointer and values count.
-    (move ebx ebp-tn)
+    (inst lea ebx (make-ea :dword :base ebp-tn
+                           :disp (* sp->fp-offset n-word-bytes)))
     (if (zerop nvals)
         (inst xor ecx ecx)              ; smaller
         (inst mov ecx (fixnumize nvals)))
-    ;; Restore the frame pointer.
-    (move ebp-tn old-fp)
-    ;; Clear as much of the stack as possible, but not past the return
-    ;; address.
-    (inst lea esp-tn
-          (make-ea :dword :base ebx
-                   :disp (frame-byte-offset (max (1- nvals)
-                                                 return-pc-save-offset))))
     ;; Pre-default any argument register that need it.
     (when (< nvals register-arg-count)
       (let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
@@ -945,17 +929,25 @@
     ;; And away we go. Except that return-pc is still on the
     ;; stack and we've changed the stack pointer. So we have to
     ;; tell it to index off of EBX instead of EBP.
-    (cond ((zerop nvals)
-           ;; Return popping the return address and what's earlier in
-           ;; the frame.
-           (inst ret (* return-pc-save-offset n-word-bytes)))
-          ((= nvals 1)
-           ;; This is handled in RETURN-SINGLE.
-           (error "nvalues is 1"))
+    (cond ((<= nvals register-arg-count)
+           (inst mov esp-tn ebp-tn)
+           (inst pop ebp-tn)
+           (inst ret))
           (t
-           ;; Thou shalt not JMP unto thy return address.
+           ;; Some values are on the stack after RETURN-PC and OLD-FP,
+           ;; can't return normally and some slots of the frame will
+           ;; be used as temporaries by the receiver.
+           ;;
+           ;; Clear as much of the stack as possible, but not past the
+           ;; old frame address.
+           (inst lea esp-tn
+                 (make-ea :dword :base ebp-tn
+                          :disp (frame-byte-offset (1- nvals))))
+           (move ebp-tn old-fp)
            (inst push (make-ea :dword :base ebx
-                               :disp (frame-byte-offset (tn-offset return-pc))))
+                               :disp (frame-byte-offset
+                                      (+ sp->fp-offset
+                                         (tn-offset return-pc)))))
            (inst ret)))
 
     (trace-table-entry trace-table-normal)))
@@ -967,28 +959,21 @@
 ;;; assembly-routine.
 ;;;
 ;;; The assembly routine takes the following args:
-;;;  EAX -- the return-pc to finally jump to.
-;;;  EBX -- pointer to where to put the values.
 ;;;  ECX -- number of values to find there.
 ;;;  ESI -- pointer to where to find the values.
 (define-vop (return-multiple)
-  (:args (old-fp :to (:eval 1) :target old-fp-temp)
-         (return-pc :target eax)
+  (:args (old-fp)
+         (return-pc)
          (vals :scs (any-reg) :target esi)
          (nvals :scs (any-reg) :target ecx))
-  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax)
   (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 2)) esi)
   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 3)) ecx)
-  (:temporary (:sc unsigned-reg :offset ebx-offset :from (:eval 0)) ebx)
   (:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*)
                    :from (:eval 0)) a0)
-  (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
   (:node-var node)
   (:generator 13
     (check-ocfp-and-return-pc old-fp return-pc)
     (trace-table-entry trace-table-fun-epilogue)
-    ;; Load the return-pc.
-    (move eax return-pc)
     (unless (policy node (> space speed))
       ;; Check for the single case.
       (let ((not-single (gen-label)))
@@ -996,22 +981,17 @@
         (inst jmp :ne not-single)
         ;; Return with one value.
         (loadw a0 vals -1)
-        ;; Clear the stack. We load old-fp into a register before clearing
-        ;; the stack.
-        (move old-fp-temp old-fp)
-        (move esp-tn ebp-tn)
-        (move ebp-tn old-fp-temp)
+        ;; Clear the stack until ocfp.
+        (inst mov esp-tn ebp-tn)
         ;; clear the multiple-value return flag
         (inst clc)
         ;; Out of here.
-        (inst push eax)
+        (inst pop ebp-tn)
         (inst ret)
         ;; Nope, not the single case. Jump to the assembly routine.
         (emit-label not-single)))
     (move esi vals)
     (move ecx nvals)
-    (move ebx ebp-tn)
-    (move ebp-tn old-fp)
     (inst jmp (make-fixup 'return-multiple :assembly-routine))
     (trace-table-entry trace-table-normal)))
 
@@ -1044,7 +1024,7 @@
 ;;;
 ;;;  EAX -- The lexenv.
 ;;;  EBX -- Available.
-;;;  ECX -- The total number of arguments.
+;;;  ECX -- The total number of arguments * N-WORD-BYTES.
 ;;;  EDX -- The first arg.
 ;;;  EDI -- The second arg.
 ;;;  ESI -- The third arg.
@@ -1065,11 +1045,11 @@
            (inst jmp :be JUST-ALLOC-FRAME)))
 
     ;; Allocate the space on the stack.
-    ;; stack = ebp - (max 3 frame-size) - (nargs - fixed)
+    ;; stack = ebp + sp->fp-offset - (max 3 frame-size) - (nargs - fixed)
     (inst lea ebx-tn
           (make-ea :dword :base ebp-tn
-                   :disp (- (fixnumize fixed)
-                            (* n-word-bytes
+                   :disp (* n-word-bytes
+                            (- (+ sp->fp-offset fixed)
                                (max 3 (sb-allocated-size 'stack))))))
     (inst sub ebx-tn ecx-tn)  ; Got the new stack in ebx
     (inst mov esp-tn ebx-tn)
@@ -1098,7 +1078,8 @@
     ;; now.
 
     ;; Initialize src to be end of args.
-    (inst mov esi-tn ebp-tn)
+    (inst lea esi-tn (make-ea :dword :base ebp-tn
+                              :disp (* sp->fp-offset n-word-bytes)))
     (inst sub esi-tn ebx-tn)
 
     ;; We need to copy from downwards up to avoid overwriting some of
@@ -1130,33 +1111,37 @@
 
     ;; Here: nargs>=1 && nargs>fixed
     (when (< fixed register-arg-count)
-          ;; Now we have to deposit any more args that showed up in
-          ;; registers.
-          (do ((i fixed))
-              ( nil )
-              ;; Store it relative to ebp
-              (inst mov (make-ea :dword :base ebp-tn
-                                 :disp (- (* n-word-bytes
-                                             (+ 1 (- i fixed)
-                                                (max 3 (sb-allocated-size 'stack))))))
-                    (nth i *register-arg-tns*))
-
-              (incf i)
-              (when (>= i register-arg-count)
-                    (return))
-
-              ;; Don't deposit any more than there are.
-              (if (zerop i)
-                  (inst test ecx-tn ecx-tn)
-                (inst cmp ecx-tn (fixnumize i)))
-              (inst jmp :eq DONE)))
+      ;; Now we have to deposit any more args that showed up in
+      ;; registers.
+      (do ((i fixed))
+          ( nil )
+        ;; Store it relative to ebp
+        (inst mov (make-ea :dword :base ebp-tn
+                           :disp (* n-word-bytes
+                                    (- sp->fp-offset
+                                       (+ 1
+                                          (- i fixed)
+                                          (max 3 (sb-allocated-size
+                                                  'stack))))))
+              (nth i *register-arg-tns*))
+
+        (incf i)
+        (when (>= i register-arg-count)
+          (return))
+
+        ;; Don't deposit any more than there are.
+        (if (zerop i)
+            (inst test ecx-tn ecx-tn)
+            (inst cmp ecx-tn (fixnumize i)))
+        (inst jmp :eq DONE)))
 
     (inst jmp DONE)
 
     JUST-ALLOC-FRAME
     (inst lea esp-tn
           (make-ea :dword :base ebp-tn
-                   :disp (- (* n-word-bytes
+                   :disp (* n-word-bytes
+                            (- sp->fp-offset
                                (max 3 (sb-allocated-size 'stack))))))
 
     DONE))
@@ -1220,7 +1205,6 @@
       (inst lea dst (make-ea :dword :base ecx :index ecx))
       (maybe-pseudo-atomic stack-allocate-p
        (allocation dst dst node stack-allocate-p list-pointer-lowtag)
-       (inst shr ecx (1- n-lowtag-bits))
        ;; Set decrement mode (successive args at lower addresses)
        (inst std)
        ;; Set up the result.
@@ -1238,7 +1222,7 @@
        (inst lods eax)
        (storew eax dst 0 list-pointer-lowtag)
        ;; Go back for more.
-       (inst sub ecx 1)
+       (inst sub ecx n-word-bytes)
        (inst jmp :nz loop)
        ;; NIL out the last cons.
        (storew nil-value dst 1 list-pointer-lowtag)