X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir2tran.lisp;h=ca486d1a3c882e14ffe13f47f90a15244b18cae7;hb=6822034325136cde4e14773c83c3769b42721306;hp=026b5098ff20995aa58f8a7a627513f34113edef;hpb=b9e94e326f79ab01e56cb437e424ce5ea489471f;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 026b509..ca486d1 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -52,12 +52,15 @@ (emit-move-template node block (type-check-template type) value result) (values)) -;;; Allocate an indirect value cell. Maybe do some clever stack -;;; allocation someday. +;;; Allocate an indirect value cell. (defevent make-value-cell-event "Allocate heap value cell for lexical var.") (defun emit-make-value-cell (node block value res) (event make-value-cell-event node) - (vop make-value-cell node block value res)) + (let ((leaf (tn-leaf res))) + (vop make-value-cell node block value + ;; FIXME: See bug 419 + (and leaf (eq :truly (leaf-dynamic-extent leaf))) + res))) ;;;; leaf reference @@ -131,13 +134,7 @@ (vop value-cell-ref node block tn res) (emit-move node block tn res)))) (constant - (if (legal-immediate-constant-p leaf) - (emit-move node block (constant-tn leaf) res) - (let* ((name (leaf-source-name leaf)) - (name-tn (emit-constant name))) - (if (policy node (zerop safety)) - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res))))) + (emit-move node block (constant-tn leaf) res)) (functional (ir2-convert-closure node block leaf res)) (global-var @@ -302,7 +299,7 @@ (emit-move node block val tn))))) (global-var (ecase (global-var-kind leaf) - ((:special :global) + ((:special) (aver (symbolp (leaf-source-name leaf))) (vop set node block (emit-constant (leaf-source-name leaf)) val))))) (when locs @@ -597,61 +594,49 @@ (ir2-convert-conditional node block (template-or-lose 'if-eq) test-ref () node t))) -;;; Return a list of primitive-types that we can pass to -;;; LVAR-RESULT-TNS describing the result types we want for a -;;; template call. We duplicate here the determination of output type -;;; that was done in initially selecting the template, so we know that -;;; the types we find are allowed by the template output type -;;; restrictions. -(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 - (if (values-type-p type) - (append (values-type-required type) - (values-type-optional type)) - (list type))))) - (let ((nvals (length rtypes)) - (ntypes (length types))) - (cond ((< ntypes nvals) - (append types - (make-list (- nvals ntypes) - :initial-element *backend-t-primitive-type*))) - ((> ntypes nvals) - (subseq types 0 nvals)) - (t - types))))) - -;;; Return a list of TNs usable in a CALL to TEMPLATE delivering -;;; values to LVAR. As an efficiency hack, we pick off the common case -;;; where the LVAR is fixed values and has locations that satisfy the -;;; result restrictions. This can fail when there is a type check or a -;;; values count mismatch. -(defun make-template-result-tns (call lvar template rtypes) +;;; Return a list of primitive-types that we can pass to LVAR-RESULT-TNS +;;; describing the result types we want for a template call. We are really +;;; only interested in the number of results required: in normal case +;;; TEMPLATE-RESULTS-OK has already checked them. +(defun find-template-result-types (call rtypes) + (let* ((type (node-derived-type call)) + (types + (mapcar #'primitive-type + (if (values-type-p type) + (append (args-type-required type) + (args-type-optional type)) + (list type)))) + (primitive-t *backend-t-primitive-type*)) + (loop for rtype in rtypes + for type = (or (pop types) primitive-t) + collect type))) + +;;; Return a list of TNs usable in a CALL to TEMPLATE delivering values to +;;; LVAR. As an efficiency hack, we pick off the common case where the LVAR is +;;; fixed values and has locations that satisfy the result restrictions. This +;;; can fail when there is a type check or a values count mismatch. +(defun make-template-result-tns (call lvar rtypes) (declare (type combination call) (type (or lvar null) lvar) - (type template template) (list rtypes)) + (list rtypes)) (let ((2lvar (when lvar (lvar-info lvar)))) (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed)) (let ((locs (ir2-lvar-locs 2lvar))) (if (and (= (length rtypes) (length locs)) (do ((loc locs (cdr loc)) - (rtype rtypes (cdr rtype))) + (rtypes rtypes (cdr rtypes))) ((null loc) t) (unless (operand-restriction-ok - (car rtype) + (car rtypes) (tn-primitive-type (car loc)) :t-ok nil) (return nil)))) locs (lvar-result-tns lvar - (find-template-result-types call template rtypes)))) + (find-template-result-types call rtypes)))) (lvar-result-tns lvar - (find-template-result-types call template rtypes))))) + (find-template-result-types call rtypes))))) ;;; Get the operands into TNs, make TN-REFs for them, and then call ;;; the template emit function. @@ -666,7 +651,7 @@ (if (eq rtypes :conditional) (ir2-convert-conditional call block template args info-args (lvar-dest lvar) nil) - (let* ((results (make-template-result-tns call lvar template rtypes)) + (let* ((results (make-template-result-tns call lvar rtypes)) (r-refs (reference-tn-list results t))) (aver (= (length info-args) (template-info-arg-count template))) @@ -690,7 +675,7 @@ (info (lvar-value info)) (lvar (node-lvar call)) (rtypes (template-result-types template)) - (results (make-template-result-tns call lvar template rtypes)) + (results (make-template-result-tns call lvar rtypes)) (r-refs (reference-tn-list results t))) (multiple-value-bind (args info-args) (reference-args call block (cddr (combination-args call)) template) @@ -704,6 +689,12 @@ (move-lvar-result call block results lvar))) (values)) + +(defoptimizer (%%primitive derive-type) ((template info &rest args)) + (let ((type (template-type (lvar-value template)))) + (if (fun-type-p type) + (fun-type-returns type) + *wild-type*))) ;;;; local call @@ -1179,6 +1170,13 @@ (ir2-physenv-return-pc-pass env) (ir2-physenv-return-pc env)) + #!+unwind-to-frame-and-call-vop + (when (and (lambda-allow-instrumenting fun) + (not (lambda-inline-expanded fun)) + (lambda-return fun) + (policy fun (>= insert-debug-catch 2))) + (vop sb!vm::bind-sentinel node block)) + (let ((lab (gen-label))) (setf (ir2-physenv-environment-start env) lab) (vop note-environment-start node block lab))) @@ -1204,6 +1202,11 @@ (old-fp (ir2-physenv-old-fp env)) (return-pc (ir2-physenv-return-pc env)) (returns (tail-set-info (lambda-tail-set fun)))) + #!+unwind-to-frame-and-call-vop + (when (and (lambda-allow-instrumenting fun) + (not (lambda-inline-expanded fun)) + (policy fun (>= insert-debug-catch 2))) + (vop sb!vm::unbind-sentinel node block)) (cond ((and (eq (return-info-kind returns) :fixed) (not (xep-p fun))) @@ -1426,20 +1429,35 @@ (progn (labels ((,unbind (vars) (declare (optimize (speed 2) (debug 0))) - (dolist (var vars) - (%primitive bind nil var) - (makunbound var))) + (let ((unbound-marker (%primitive make-other-immediate-type + 0 sb!vm:unbound-marker-widetag))) + (dolist (var vars) + ;; CLHS says "bound and then made to have no value" -- user + ;; should not be able to tell the difference between that and this. + (about-to-modify-symbol-value var "bind ~S") + (%primitive bind unbound-marker var)))) (,bind (vars vals) (declare (optimize (speed 2) (debug 0))) (cond ((null vars)) ((null vals) (,unbind vars)) - (t (%primitive bind - (car vals) - (car vars)) - (,bind (cdr vars) (cdr vals)))))) + (t + (let ((val (car vals)) + (var (car vars))) + (about-to-modify-symbol-value var "bind ~S" val) + (%primitive bind val var)) + (,bind (cdr vars) (cdr vals)))))) (,bind ,vars ,vals)) nil ,@body) + ;; Technically ANSI CL doesn't allow declarations at the + ;; start of the cleanup form. SBCL happens to allow for + ;; them, due to the way the UNWIND-PROTECT ir1 translation + ;; is implemented; the cleanup forms are directly spliced + ;; into an FLET definition body. And a declaration here + ;; actually has exactly the right scope for what we need + ;; (ensure that debug instrumentation is not emitted for the + ;; cleanup function). -- JES, 2007-06-16 + (declare (optimize (insert-debug-catch 0))) (%primitive unbind-to-here ,n-save-bs)))))) ;;;; non-local exit