;;;
;;; frame-return-guts.lisp
;;;
;;; Guts of frame-return for SBCL/x86.
;;;

(in-package :sb-c)

;; %frame-return needs the same sort of special-casing in the
;; compiler as %throw does. ir1-optimize-mv-combination in ir1opt.lisp
;; and ltn-analyze-mv-call in ltn.lisp. And don't forget the defknown.
;; Also needs a patch in ir2-convert-block in ir2tran.lisp.

(defknown %frame-return (t t &rest t) nil) ; This is MV-called.

;;; Do stuff to notice a change to a MV combination node. There are
;;; two main branches here:
;;;  -- If the call is local, then it is already a MV let, or should
;;;     become one. Note that although all :LOCAL MV calls must eventually
;;;     be converted to :MV-LETs, there can be a window when the call
;;;     is local, but has not been LET converted yet. This is because
;;;     the entry-point lambdas may have stray references (in other
;;;     entry points) that have not been deleted yet.
;;;  -- The call is full. This case is somewhat similar to the non-MV
;;;     combination optimization: we propagate return type information and
;;;     notice non-returning calls. We also have an optimization
;;;     which tries to convert MV-CALLs into MV-binds.
(defun ir1-optimize-mv-combination (node)
  (ecase (basic-combination-kind node)
    (:local
     (let ((fun-lvar (basic-combination-fun node)))
       (when (lvar-reoptimize fun-lvar)
         (setf (lvar-reoptimize fun-lvar) nil)
         (maybe-let-convert (combination-lambda node))))
     (setf (lvar-reoptimize (first (basic-combination-args node))) nil)
     (when (eq (functional-kind (combination-lambda node)) :mv-let)
       (unless (convert-mv-bind-to-let node)
         (ir1-optimize-mv-bind node))))
    (:full
     (let* ((fun (basic-combination-fun node))
            (fun-changed (lvar-reoptimize fun))
            (args (basic-combination-args node)))
       (when fun-changed
         (setf (lvar-reoptimize fun) nil)
         (let ((type (lvar-type fun)))
           (when (fun-type-p type)
             (derive-node-type node (fun-type-returns type))))
         (maybe-terminate-block node nil)
         (let ((use (lvar-uses fun)))
           (when (and (ref-p use) (functional-p (ref-leaf use)))
             (convert-call-if-possible use node)
             (when (eq (basic-combination-kind node) :local)
               (maybe-let-convert (ref-leaf use))))))
       (unless (or (eq (basic-combination-kind node) :local)
                   (eq (lvar-fun-name fun) '%throw)
		   (eq (lvar-fun-name fun) '%frame-return))
         (ir1-optimize-mv-call node))
       (dolist (arg args)
         (setf (lvar-reoptimize arg) nil))))
    (:error))
  (values))


;;; We force all the argument lvars to use the unknown values
;;; convention. The lvars are annotated in reverse order, since the
;;; last argument is on top, thus must be popped first. We disallow
;;; delayed evaluation of the function lvar to simplify IR2 conversion
;;; of MV call.
;;;
;;; We could be cleverer when we know the number of values returned by
;;; the lvars, but optimizations of MV call are probably unworthwhile.
;;;
;;; We are also responsible for handling THROW, which is represented
;;; in IR1 as an MV call to the %THROW funny function. We annotate the
;;; tag lvar for a single value and the values lvar for unknown
;;; values.
(defun ltn-analyze-mv-call (call)
  (declare (type mv-combination call))
  (let ((fun (basic-combination-fun call))
        (args (basic-combination-args call)))
    (cond ((eq (lvar-fun-name fun) '%throw)
           (setf (basic-combination-info call) :funny)
           (annotate-ordinary-lvar (first args))
           (annotate-unknown-values-lvar (second args))
           (setf (node-tail-p call) nil))
	  ((eq (lvar-fun-name fun) '%frame-return)
	   (setf (basic-combination-info call) :funny)
	   (annotate-ordinary-lvar (first args))
	   (annotate-ordinary-lvar (second args))
	   (annotate-unknown-values-lvar (third args))
	   (setf (node-tail-p call) nil))
          (t
           (setf (basic-combination-info call) :full)
           (annotate-fun-lvar (basic-combination-fun call) nil)
           (dolist (arg (reverse args))
             (annotate-unknown-values-lvar arg))
           (flush-full-call-tail-transfer call))))

  (values))

(in-package :sb-vm)

;;; Compute the address of the catch block from its TN, then store into the
;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
(define-vop (return-from-frame)
  (:args (ofp :scs #+nil (sap-reg) (#+nil any-reg descriptor-reg))
	 (uwp :scs #+nil (sap-reg) (#+nil any-reg descriptor-reg))
	 (tn)
	 (start :scs (any-reg descriptor-reg) :target ebx)
	 (count :scs (any-reg descriptor-reg) :target ecx))
  (:arg-types system-area-pointer system-area-pointer t t t)

  (:temporary (:sc unsigned-reg :offset ebx-offset :from (:argument 3)) ebx)
  (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 4)) ecx)
  (:temporary (:sc sap-reg) temp)
  (:temporary (:sc unsigned-reg :offset eax-offset) block)

  (:generator 22
    ;; Set up magic catch / UWP block.
    (inst lea block (catch-block-ea tn))
    (loadw temp uwp sap-pointer-slot other-pointer-lowtag)
    (storew temp block unwind-block-current-uwp-slot)
    (loadw temp ofp sap-pointer-slot other-pointer-lowtag)
    (storew temp block unwind-block-current-cont-slot)

    (storew (make-fixup nil :code-object entry-label)
            block catch-block-entry-pc-slot)

    ;; Fix up args.
    (move ebx start)
    (move ecx count)

    ;; Run any required UWPs.
    (inst jmp (make-fixup 'unwind :assembly-routine))
    ENTRY-LABEL

    ;; Now just inline the core bit of return-multiple.
    ;; We get here with start and count in EBX and ECX,
    ;; and EBP already points to the frame we want to
    ;; return from. We need to set EBX to the value of
    ;; EBP, ESI and ECX to start and count, and EAX to
    ;; the return value from the frame, then jump to
    ;; the assem-routine.
    (inst mov esi-tn ebx-tn)
    (inst mov ebx-tn ebp-tn)
    (inst mov eax-tn (make-ea :dword :base ebp-tn
			      :disp (- (* n-word-bytes
					  (1+ return-pc-save-offset)))))
    (inst mov ebp-tn (make-ea :dword :base ebp-tn
			      :disp (- (* n-word-bytes
					  (1+ ocfp-save-offset)))))

    (inst jmp (make-fixup 'return-multiple :assembly-routine))))

(in-package :sb-c)

;;; We have to do a spurious move of no values to the result lvar so
;;; that lifetime analysis won't get confused.
(defun ir2-convert-frame-return (node block)
  (declare (type mv-combination node) (type ir2-block block))
  (let* ((args (basic-combination-args node))
	 (block-tn (physenv-live-tn
		    (make-normal-tn (primitive-type-or-lose 'catch-block))
		    (node-physenv node))))
    ;; First two args are SAPs for the frame pointer and a UWP-block.
    ;; Third arg is the values to return.
    ;(check-catch-tag-type (first args))
    (vop* sb-vm::return-from-frame node block
          ((lvar-tn node block (first args))
	   (lvar-tn node block (second args))
	   block-tn
           (reference-tn-list
            (ir2-lvar-locs (lvar-info (third args)))
            nil))
          (nil)))
  (move-lvar-result node block () (node-lvar node))
  (values))


;;; Convert the code in a block into VOPs.
(defun ir2-convert-block (block)
  (declare (type cblock block))
  (let ((2block (block-info block)))
    (do-nodes (node lvar block)
      (etypecase node
        (ref
         (when lvar
           (let ((2lvar (lvar-info lvar)))
             ;; function REF in a local call is not annotated
             (when (and 2lvar (not (eq (ir2-lvar-kind 2lvar) :delayed)))
               (ir2-convert-ref node 2block)))))
        (combination
         (let ((kind (basic-combination-kind node)))
           (ecase kind
             (:local
              (ir2-convert-local-call node 2block))
             (:full
              (ir2-convert-full-call node 2block))
             (:known
              (let* ((info (basic-combination-fun-info node))
                     (fun (fun-info-ir2-convert info)))
                (cond (fun
                       (funcall fun node 2block))
                      ((eq (basic-combination-info node) :full)
                       (ir2-convert-full-call node 2block))
                      (t
                       (ir2-convert-template node 2block))))))))
        (cif
         (when (lvar-info (if-test node))
           (ir2-convert-if node 2block)))
        (bind
         (let ((fun (bind-lambda node)))
           (when (eq (lambda-home fun) fun)
             (ir2-convert-bind node 2block))))
        (creturn
         (ir2-convert-return node 2block))
        (cset
         (ir2-convert-set node 2block))
        (cast
         (ir2-convert-cast node 2block))
        (mv-combination
         (cond
           ((eq (basic-combination-kind node) :local)
            (ir2-convert-mv-bind node 2block))
           ((eq (lvar-fun-name (basic-combination-fun node))
                '%throw)
            (ir2-convert-throw node 2block))
	   ((eq (lvar-fun-name (basic-combination-fun node))
		'%frame-return)
	    (ir2-convert-frame-return node 2block))
           (t
            (ir2-convert-mv-call node 2block))))
        (exit
         (when (exit-entry node)
           (ir2-convert-exit node 2block)))
        (entry
         (ir2-convert-entry node 2block)))))

  (finish-ir2-block block)

  (values))

;;; EOF