(ir2-nlx-info-home (nlx-info-info thing))))))
;;; If LEAF already has a constant TN, return that, otherwise make a
(ir2-nlx-info-home (nlx-info-info thing))))))
;;; If LEAF already has a constant TN, return that, otherwise make a
(let ((unsafe (policy node (zerop safety))))
(ecase (global-var-kind leaf)
((:special :global :constant)
(let ((unsafe (policy node (zerop safety))))
(ecase (global-var-kind leaf)
((:special :global :constant)
(vop set node block (emit-constant (leaf-name leaf)) val)))))
(when locs
(emit-move node block val (first locs))
(vop set node block (emit-constant (leaf-name leaf)) val)))))
(when locs
(emit-move node block val (first locs))
(first (ir2-continuation-locs 2cont)))))
(ptype (ir2-continuation-primitive-type 2cont)))
(cond ((and (eq (continuation-type-check cont) t)
(multiple-value-bind (check types)
(continuation-check-types cont)
(first (ir2-continuation-locs 2cont)))))
(ptype (ir2-continuation-primitive-type 2cont)))
(cond ((and (eq (continuation-type-check cont) t)
(multiple-value-bind (check types)
(continuation-check-types cont)
;; If the proven type is a subtype of the possibly
;; weakened type check then it's always true and is
;; flushed.
;; If the proven type is a subtype of the possibly
;; weakened type check then it's always true and is
;; flushed.
(type continuation cont) (list ptypes))
(let* ((locs (ir2-continuation-locs (continuation-info cont)))
(nlocs (length locs)))
(type continuation cont) (list ptypes))
(let* ((locs (ir2-continuation-locs (continuation-info cont)))
(nlocs (length locs)))
(if (eq (continuation-type-check cont) t)
(multiple-value-bind (check types) (continuation-check-types cont)
(if (eq (continuation-type-check cont) t)
(multiple-value-bind (check types) (continuation-check-types cont)
(let ((ntypes (length types)))
(mapcar #'(lambda (from to-type assertion)
(let ((temp (make-normal-tn to-type)))
(let ((ntypes (length types)))
(mapcar #'(lambda (from to-type assertion)
(let ((temp (make-normal-tn to-type)))
(declare (type node node) (type ir2-block block)
(type template template) (type (or tn-ref null) args)
(list info-args) (type cif if) (type boolean not-p))
(declare (type node node) (type ir2-block block)
(type template template) (type (or tn-ref null) args)
(list info-args) (type cif if) (type boolean not-p))
(let ((consequent (if-consequent if))
(alternative (if-alternative if)))
(cond ((drop-thru-p if consequent)
(let ((consequent (if-consequent if))
(alternative (if-alternative if)))
(cond ((drop-thru-p if consequent)
(rtypes (template-result-types template)))
(multiple-value-bind (args info-args)
(reference-arguments call block (combination-args call) template)
(rtypes (template-result-types template)))
(multiple-value-bind (args info-args)
(reference-arguments call block (combination-args call) template)
(if (eq rtypes :conditional)
(ir2-convert-conditional call block template args info-args
(continuation-dest cont) nil)
(let* ((results (make-template-result-tns call cont template rtypes))
(r-refs (reference-tn-list results t)))
(if (eq rtypes :conditional)
(ir2-convert-conditional call block template args info-args
(continuation-dest cont) nil)
(let* ((results (make-template-result-tns call cont template rtypes))
(r-refs (reference-tn-list results t)))
(if info-args
(emit-template call block template args r-refs info-args)
(emit-template call block template args r-refs))
(if info-args
(emit-template call block template args r-refs info-args)
(emit-template call block template args r-refs))
- (assert (not (template-more-results-type template)))
- (assert (not (eq rtypes :conditional)))
- (assert (null info-args))
+ (aver (not (template-more-results-type template)))
+ (aver (not (eq rtypes :conditional)))
+ (aver (null info-args))
(let ((2cont (continuation-info cont)))
(if (eq (ir2-continuation-kind 2cont) :delayed)
(let ((name (continuation-function-name cont t)))
(let ((2cont (continuation-info cont)))
(if (eq (ir2-continuation-kind 2cont) :delayed)
(let ((name (continuation-function-name cont t)))
(values (make-load-time-constant-tn :fdefinition name) t))
(let* ((locs (ir2-continuation-locs 2cont))
(loc (first locs))
(check (continuation-type-check cont))
(function-ptype (primitive-type-or-lose 'function)))
(values (make-load-time-constant-tn :fdefinition name) t))
(let* ((locs (ir2-continuation-locs 2cont))
(loc (first locs))
(check (continuation-type-check cont))
(function-ptype (primitive-type-or-lose 'function)))
(setf (gethash stem *setf-assumed-fboundp*) t)))))
;;; If the call is in a tail recursive position and the return
(setf (gethash stem *setf-assumed-fboundp*) t)))))
;;; If the call is in a tail recursive position and the return
(declare (type bind node) (type ir2-block block))
(let* ((fun (bind-lambda node))
(env (environment-info (lambda-environment fun))))
(declare (type bind node) (type ir2-block block))
(let* ((fun (bind-lambda node))
(env (environment-info (lambda-environment fun))))
(let* ((cont (first (basic-combination-args node)))
(fun (ref-leaf (continuation-use (basic-combination-fun node))))
(vars (lambda-vars fun)))
(let* ((cont (first (basic-combination-args node)))
(fun (ref-leaf (continuation-use (basic-combination-fun node))))
(vars (lambda-vars fun)))
;;; contiguous and on stack top.
(defun ir2-convert-mv-call (node block)
(declare (type mv-combination node) (type ir2-block block))
;;; contiguous and on stack top.
(defun ir2-convert-mv-call (node block)
(declare (type mv-combination node) (type ir2-block block))
(let* ((start-cont (continuation-info (first (basic-combination-args node))))
(start (first (ir2-continuation-locs start-cont)))
(tails (and (node-tail-p node)
(let* ((start-cont (continuation-info (first (basic-combination-args node))))
(start (first (ir2-continuation-locs start-cont)))
(tails (and (node-tail-p node)
(2cont (continuation-info cont)))
(multiple-value-bind (fun named)
(function-continuation-tn node block (basic-combination-fun node))
(2cont (continuation-info cont)))
(multiple-value-bind (fun named)
(function-continuation-tn node block (basic-combination-fun node))
;;; top of it.)
(defoptimizer (%pop-values ir2-convert) ((continuation) node block)
(let ((2cont (continuation-info (continuation-value continuation))))
;;; top of it.)
(defoptimizer (%pop-values ir2-convert) ((continuation) node block)
(let ((2cont (continuation-info (continuation-value continuation))))
-;;; ### Not clear that this really belongs in this file, or should
-;;; really be done this way, but this is the least violation of
+;;; ### It's not clear that this really belongs in this file, or
+;;; should really be done this way, but this is the least violation of
;;; abstraction in the current setup. We don't want to wire
;;; shallow-binding assumptions into IR1tran.
(def-ir1-translator progv ((vars vals &body body) start cont)
(ir1-convert
start cont
;;; abstraction in the current setup. We don't want to wire
;;; shallow-binding assumptions into IR1tran.
(def-ir1-translator progv ((vars vals &body body) start cont)
(ir1-convert
start cont
`(%progv ,vars ,vals #'(lambda () ,@body))
(once-only ((n-save-bs '(%primitive current-binding-pointer)))
`(unwind-protect
`(%progv ,vars ,vals #'(lambda () ,@body))
(once-only ((n-save-bs '(%primitive current-binding-pointer)))
`(unwind-protect
(let ((target (first succ)))
(cond ((eq target (component-tail (block-component block)))
(when (and (basic-combination-p last)
(let ((target (first succ)))
(cond ((eq target (component-tail (block-component block)))
(when (and (basic-combination-p last)
tn)))))))
((not (eq (ir2-block-next 2block) (block-info target)))
(vop branch last 2block (block-label target)))))))
tn)))))))
((not (eq (ir2-block-next 2block) (block-info target)))
(vop branch last 2block (block-label target)))))))