(defun find-template-result-types (call template rtypes)
(declare (type combination call)
(type template template) (list rtypes))
+ (declare (ignore template))
(let* ((dtype (node-derived-type call))
(type dtype)
(types (mapcar #'primitive-type
(r-refs (reference-tn-list results t)))
(aver (= (length info-args)
(template-info-arg-count template)))
+ #!+stack-grows-downward-not-upward
+ (when (and lvar (lvar-dynamic-extent lvar))
+ (vop current-stack-pointer call block
+ (ir2-lvar-stack-pointer (lvar-info lvar))))
(if info-args
(emit-template call block template args r-refs info-args)
(emit-template call block template args r-refs))
;;; lvar LOC.
;;; -- We don't know what it is.
(defun fun-lvar-tn (node block lvar)
+ (declare (ignore node block))
(declare (type lvar lvar))
(let ((2lvar (lvar-info lvar)))
(if (eq (ir2-lvar-kind 2lvar) :delayed)
(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
(let ((ir2-physenv (physenv-info (node-physenv node))))
(move-lvar-result node block
- (list (ir2-physenv-old-fp ir2-physenv)
- (ir2-physenv-return-pc ir2-physenv))
- (node-lvar node))))
+ (list (ir2-physenv-old-fp ir2-physenv)
+ (ir2-physenv-return-pc ir2-physenv))
+ (node-lvar node))))
\f
;;;; multiple values
;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates
-;;; the lvarinuation for the correct number of values (with the lvar
-;;; user responsible for defaulting), we can just pick them up from
-;;; the lvar.
+;;; the lvar for the correct number of values (with the lvar user
+;;; responsible for defaulting), we can just pick them up from the
+;;; lvar.
(defun ir2-convert-mv-bind (node block)
(declare (type mv-combination node) (type ir2-block block))
(let* ((lvar (first (basic-combination-args node)))
;;; Reset the stack pointer to the start of the specified
;;; unknown-values lvar (discarding it and all values globs on top of
;;; it.)
-(defoptimizer (%pop-values ir2-convert) ((lvar) node block)
- (let ((2lvar (lvar-info (lvar-value lvar))))
- (aver (eq (ir2-lvar-kind 2lvar) :unknown))
- (vop reset-stack-pointer node block
- (first (ir2-lvar-locs 2lvar)))))
+(defoptimizer (%pop-values ir2-convert) ((%lvar) node block)
+ (let* ((lvar (lvar-value %lvar))
+ (2lvar (lvar-info lvar)))
+ (cond ((eq (ir2-lvar-kind 2lvar) :unknown)
+ (vop reset-stack-pointer node block
+ (first (ir2-lvar-locs 2lvar))))
+ ((lvar-dynamic-extent lvar)
+ #!+stack-grows-downward-not-upward
+ (vop reset-stack-pointer node block
+ (ir2-lvar-stack-pointer 2lvar))
+ #!-stack-grows-downward-not-upward
+ (vop %%pop-dx node block
+ (first (ir2-lvar-locs 2lvar))))
+ (t (bug "Trying to pop a not stack-allocated LVAR ~S."
+ lvar)))))
+
+(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved
+ &rest moved)
+ node block)
+ (let* ( ;; pointer immediately after the nipped block
+ (after (lvar-value last-nipped))
+ (2after (lvar-info after))
+ ;; pointer to the first nipped word
+ (first (lvar-value last-preserved))
+ (2first (lvar-info first))
+
+ (moved-tns (loop for lvar-ref in moved
+ for lvar = (lvar-value lvar-ref)
+ for 2lvar = (lvar-info lvar)
+ ;when 2lvar
+ collect (first (ir2-lvar-locs 2lvar)))))
+ (aver (or (eq (ir2-lvar-kind 2after) :unknown)
+ (lvar-dynamic-extent after)))
+ (aver (eq (ir2-lvar-kind 2first) :unknown))
+ (when *check-consistency*
+ ;; we cannot move stack-allocated DX objects
+ (dolist (moved-lvar moved)
+ (aver (eq (ir2-lvar-kind (lvar-info (lvar-value moved-lvar)))
+ :unknown))))
+ (flet ((nip-aligned (nipped)
+ (vop* %%nip-values node block
+ (nipped
+ (first (ir2-lvar-locs 2first))
+ (reference-tn-list moved-tns nil))
+ ((reference-tn-list moved-tns t))))
+ #!-stack-grows-downward-not-upward
+ (nip-unaligned (nipped)
+ (vop* %%nip-dx node block
+ (nipped
+ (first (ir2-lvar-locs 2first))
+ (reference-tn-list moved-tns nil))
+ ((reference-tn-list moved-tns t)))))
+ (cond ((eq (ir2-lvar-kind 2after) :unknown)
+ (nip-aligned (first (ir2-lvar-locs 2after))))
+ ((lvar-dynamic-extent after)
+ #!+stack-grows-downward-not-upward
+ (nip-aligned (ir2-lvar-stack-pointer 2after))
+ #!-stack-grows-downward-not-upward
+ (nip-unaligned (ir2-lvar-stack-pointer 2after)))
+ (t
+ (bug "Trying to nip a not stack-allocated LVAR ~S." after))))))
;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT.
(defoptimizer (values ir2-convert) ((&rest values) node block)
(res (lvar-result-tns
lvar
(list (primitive-type (specifier-type 'list))))))
+ #!+stack-grows-downward-not-upward
+ (when (and lvar (lvar-dynamic-extent lvar))
+ (vop current-stack-pointer node block
+ (ir2-lvar-stack-pointer (lvar-info lvar))))
(vop* ,name node block (refs) ((first res) nil)
(length args))
(move-lvar-result node block res lvar)))))
(def list)
(def list*))
+
\f
;;; Convert the code in a component into VOPs.
(defun ir2-convert (component)
(ir2-convert-ref node 2block)))))
(combination
(let ((kind (basic-combination-kind node)))
- (case kind
+ (ecase kind
(:local
(ir2-convert-local-call node 2block))
(:full
(ir2-convert-full-call node 2block))
- (t
- (let ((fun (fun-info-ir2-convert kind)))
+ (: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)
projects / sbcl.git / blobdiff