(cond
((lvar-delayed-leaf lvar)
(setf (ir2-lvar-kind info) :delayed))
- (t (setf (ir2-lvar-locs info)
- (list (make-normal-tn (ir2-lvar-primitive-type info)))))))
+ (t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info))))
+ (setf (ir2-lvar-locs info) (list tn))
+ #!+stack-grows-downward-not-upward
+ (when (lvar-dynamic-extent lvar)
+ (setf (ir2-lvar-stack-pointer info)
+ (make-stack-pointer-tn)))))))
(ltn-annotate-casts lvar)
(values))
;;; reference, otherwise we annotate for a single value.
(defun annotate-fun-lvar (lvar &optional (delay t))
(declare (type lvar lvar))
+ (aver (not (lvar-dynamic-extent lvar)))
(let* ((tn-ptype (primitive-type (lvar-type lvar)))
(info (make-ir2-lvar tn-ptype)))
(setf (lvar-info lvar) info)
;;; can bail out to here.
(defun ltn-default-call (call)
(declare (type combination call))
- (let ((kind (basic-combination-kind call)))
+ (let ((kind (basic-combination-kind call))
+ (info (basic-combination-fun-info call)))
(annotate-fun-lvar (basic-combination-fun call))
(dolist (arg (basic-combination-args call))
(annotate-1-value-lvar arg))
(cond
- ((and (fun-info-p kind)
- (fun-info-ir2-convert kind))
+ ((and (eq kind :known)
+ (fun-info-p info)
+ (fun-info-ir2-convert info))
(setf (basic-combination-info call) :funny)
(setf (node-tail-p call) nil))
(t
(defun annotate-unknown-values-lvar (lvar)
(declare (type lvar lvar))
+ (aver (not (lvar-dynamic-extent lvar)))
(let ((2lvar (make-ir2-lvar nil)))
(setf (ir2-lvar-kind 2lvar) :unknown)
(setf (ir2-lvar-locs 2lvar) (make-unknown-values-locations))
;;; specified primitive TYPES.
(defun annotate-fixed-values-lvar (lvar types)
(declare (type lvar lvar) (list types))
- (let ((res (make-ir2-lvar nil)))
- (setf (ir2-lvar-locs res) (mapcar #'make-normal-tn types))
- (setf (lvar-info lvar) res))
+ (let ((info (make-ir2-lvar nil)))
+ (setf (ir2-lvar-locs info) (mapcar #'make-normal-tn types))
+ (setf (lvar-info lvar) info)
+ (when (lvar-dynamic-extent lvar)
+ (aver (proper-list-of-length-p types 1))
+ #!+stack-grows-downward-not-upward
+ (setf (ir2-lvar-stack-pointer info)
+ (make-stack-pointer-tn))))
(ltn-annotate-casts lvar)
(values))
\f
(setf (node-tail-p call) nil))
(t
(setf (basic-combination-info call) :full)
- (annotate-fun-lvar (basic-combination-fun call)
- nil)
+ (annotate-fun-lvar (basic-combination-fun call) nil)
(dolist (arg (reverse args))
(annotate-unknown-values-lvar arg))
(flush-full-call-tail-transfer call))))
ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil))
+
+;;; Make sure that arguments of magic functions are not annotated.
+;;; (Otherwise the compiler may dump its internal structures as
+;;; constants :-()
+(defoptimizer (%pop-values ltn-annotate) ((%lvar) node ltn-policy)
+ %lvar node ltn-policy)
+(defoptimizer (%nip-values ltn-annotate) ((last-nipped last-preserved
+ &rest moved)
+ node ltn-policy)
+ last-nipped last-preserved moved node ltn-policy)
+
\f
;;;; known call annotation
(defun template-args-ok (template call safe-p)
(declare (type template template)
(type combination call))
+ (declare (ignore safe-p))
(let ((mtype (template-more-args-type template)))
(do ((args (basic-combination-args call) (cdr args))
(types (template-arg-types template) (cdr types)))
(declare (type combination call)
(type ltn-policy ltn-policy))
(let ((safe-p (ltn-policy-safe-p ltn-policy))
- (current (fun-info-templates (basic-combination-kind call)))
+ (current (fun-info-templates (basic-combination-fun-info call)))
(fallback nil)
(rejected nil))
(loop
(or template
(template-or-lose 'call-named)))
*efficiency-note-cost-threshold*)))
- (dolist (try (fun-info-templates (basic-combination-kind call)))
+ (dolist (try (fun-info-templates (basic-combination-fun-info call)))
(when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
(let ((guard (template-guard try)))
(when (and (or (not guard) (funcall guard))
(when (losers)
(collect ((messages)
- (count 0 +))
+ (notes 0 +))
(flet ((lose1 (string &rest stuff)
(messages string)
(messages stuff)))
(dolist (loser (losers))
(when (and *efficiency-note-limit*
- (>= (count) *efficiency-note-limit*))
+ (>= (notes) *efficiency-note-limit*))
(lose1 "etc.")
(return))
(let* ((type (template-type loser))
(t
(aver (ltn-policy-safe-p ltn-policy))
(lose1 "can't trust output type assertion under safe policy")))
- (count 1))))
+ (notes 1))))
(let ((*compiler-error-context* call))
(compiler-notify "~{~?~^~&~6T~}"
(defun ltn-analyze-known-call (call)
(declare (type combination call))
(let ((ltn-policy (node-ltn-policy call))
- (method (fun-info-ltn-annotate (basic-combination-kind call)))
+ (method (fun-info-ltn-annotate (basic-combination-fun-info call)))
(args (basic-combination-args call)))
(when method
(funcall method call ltn-policy)
(and (leaf-has-source-name-p funleaf)
(eq (lvar-fun-name (combination-fun call))
(leaf-source-name funleaf))
- (let ((info (basic-combination-kind call)))
+ (let ((info (basic-combination-fun-info call)))
(not (or (fun-info-ir2-convert info)
(ir1-attributep (fun-info-attributes info)
recursive))))))
(when (and (cast-type-check cast)
(not (node-lvar cast)))
;; FIXME
- (bug "IR2 type checking of unused values in not implemented.")
+ (bug "IR2 type checking of unused values is not implemented.")
)
(values))
(etypecase node
(ref)
(combination
- (case (basic-combination-kind node)
+ (ecase (basic-combination-kind node)
(:local (ltn-analyze-local-call node))
((:full :error) (ltn-default-call node))
- (t
+ (:known
(ltn-analyze-known-call node))))
(cif (ltn-analyze-if node))
(creturn (ltn-analyze-return node))
projects / sbcl.git / blobdiff