X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=619ebbc0d9e537b6eea2543b1ae9d167dc2214bd;hb=94ea2b2082deaa0331dfb66fa6af6ca12dd8dc83;hp=b38fa17b7ddaee3d65932e08220d4a9ff2df7585;hpb=61c18727668ff0c3263a3d363e609d4522d545cc;p=sbcl.git diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index b38fa17..619ebbc 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -67,13 +67,24 @@ ;;; Return true if a constant LEAF is of a type which we can legally ;;; directly reference in code. Named constants with arbitrary pointer ;;; values cannot, since we must preserve EQLness. +;;; +;;; FIXME: why not? The values in a function's constant vector are +;;; subject to being moved by the garbage collector. Having arbitrary +;;; values in said vector doesn't seem like a problem. (defun legal-immediate-constant-p (leaf) (declare (type constant leaf)) (or (not (leaf-has-source-name-p leaf)) - (typecase (constant-value leaf) - ((or number character) t) - (symbol (symbol-package (constant-value leaf))) - (t nil)))) + ;; Specialized arrays are legal, too. KLUDGE: this would be + ;; *much* cleaner if SIMPLE-UNBOXED-ARRAY was defined on the host. + #.(loop for saetp across sb!vm:*specialized-array-element-type-properties* + unless (eq t (sb!vm:saetp-specifier saetp)) + collect `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) t) into cases + finally (return + `(typecase (constant-value leaf) + ((or number character) t) + (symbol (symbol-package (constant-value leaf))) + ,@cases + (t nil)))))) ;;; If LVAR is used only by a REF to a leaf that can be delayed, then ;;; return the leaf, otherwise return NIL. @@ -98,8 +109,11 @@ (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)) + (when (lvar-dynamic-extent lvar) + (setf (ir2-lvar-stack-pointer info) + (make-stack-pointer-tn))))))) (ltn-annotate-casts lvar) (values)) @@ -118,6 +132,7 @@ ;;; 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) @@ -159,7 +174,8 @@ ;;; 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)) @@ -169,8 +185,9 @@ (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 @@ -193,6 +210,7 @@ (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)) @@ -217,9 +235,13 @@ ;;; 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)) + (setf (ir2-lvar-stack-pointer info) + (make-stack-pointer-tn)))) (ltn-annotate-casts lvar) (values)) @@ -311,8 +333,7 @@ (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)))) @@ -394,6 +415,17 @@ 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) + ;;;; known call annotation @@ -432,6 +464,7 @@ (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))) @@ -566,7 +599,7 @@ (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 @@ -670,7 +703,7 @@ (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)) @@ -693,13 +726,13 @@ (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)) @@ -718,7 +751,7 @@ (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~}" @@ -740,7 +773,7 @@ (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) @@ -768,7 +801,7 @@ (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)))))) @@ -800,7 +833,7 @@ (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)) @@ -847,10 +880,10 @@ (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))