X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=b5643899bf3098891947b47a8a3545c8b3e3709e;hb=c7de1989d006e0b3a4f26143b7a81c9bdb754101;hp=1c3ed43ecbb69bd04572cc60ee3ecf3f539c97ef;hpb=a0a198faba322eccaf947862b59946aed99b2347;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 1c3ed43..b564389 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -233,7 +233,7 @@ (emit-move ref ir2-block entry res)))) (values)) -;;; Convert a SET node. If the node's CONT is annotated, then we also +;;; Convert a SET node. If the NODE's CONT is annotated, then we also ;;; deliver the value to that continuation. If the var is a lexical ;;; variable with no refs, then we don't actually set anything, since ;;; the variable has been deleted. @@ -266,7 +266,7 @@ ;;;; utilities for receiving fixed values ;;; Return a TN that can be referenced to get the value of CONT. CONT -;;; must be LTN-Annotated either as a delayed leaf ref or as a fixed, +;;; must be LTN-ANNOTATED either as a delayed leaf ref or as a fixed, ;;; single-value continuation. If a type check is called for, do it. ;;; ;;; The primitive-type of the result will always be the same as the @@ -289,20 +289,7 @@ (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) - (aver (eq check :simple)) - ;; If the proven type is a subtype of the possibly - ;; weakened type check then it's always true and is - ;; flushed. - (unless (values-subtypep (continuation-proven-type cont) - (first types)) - (let ((temp (make-normal-tn ptype))) - (emit-type-check node block cont-tn temp - (first types)) - temp))))) - ((eq (tn-primitive-type cont-tn) ptype) cont-tn) + (cond ((eq (tn-primitive-type cont-tn) ptype) cont-tn) (t (let ((temp (make-normal-tn ptype))) (emit-move node block cont-tn temp) @@ -322,29 +309,15 @@ (let* ((locs (ir2-continuation-locs (continuation-info cont))) (nlocs (length locs))) (aver (= nlocs (length ptypes))) - (if (eq (continuation-type-check cont) t) - (multiple-value-bind (check types) (continuation-check-types cont) - (aver (eq check :simple)) - (let ((ntypes (length types))) - (mapcar (lambda (from to-type assertion) - (let ((temp (make-normal-tn to-type))) - (if assertion - (emit-type-check node block from temp assertion) - (emit-move node block from temp)) - temp)) - locs ptypes - (if (< ntypes nlocs) - (append types (make-list (- nlocs ntypes) - :initial-element nil)) - types)))) - (mapcar (lambda (from to-type) - (if (eq (tn-primitive-type from) to-type) - from - (let ((temp (make-normal-tn to-type))) - (emit-move node block from temp) - temp))) - locs - ptypes)))) + + (mapcar (lambda (from to-type) + (if (eq (tn-primitive-type from) to-type) + from + (let ((temp (make-normal-tn to-type))) + (emit-move node block from temp) + temp))) + locs + ptypes))) ;;;; utilities for delivering values to continuations @@ -438,6 +411,27 @@ dest)) (values)) +;;; Move each SRC TN into the corresponding DEST TN, checking types +;;; and defaulting any unsupplied source values to NIL +(defun move-results-checked (node block src dest types) + (declare (type node node) (type ir2-block block) (list src dest types)) + (let ((nsrc (length src)) + (ndest (length dest)) + (ntypes (length types))) + (mapc (lambda (from to type) + (if type + (emit-type-check node block from to type) + (emit-move node block from to))) + (if (> ndest nsrc) + (append src (make-list (- ndest nsrc) + :initial-element (emit-constant nil))) + src) + dest + (if (> ndest ntypes) + (append types (make-list (- ndest ntypes))) + types))) + (values)) + ;;; If necessary, emit coercion code needed to deliver the RESULTS to ;;; the specified continuation. NODE and BLOCK provide context for ;;; emitting code. Although usually obtained from STANDARD-RESULT-TNs @@ -467,10 +461,41 @@ ((reference-tn-list (ir2-continuation-locs 2cont) t)) nvals)))))) (values)) + +;;; CAST +(defun ir2-convert-cast (node block) + (declare (type cast node) + (type ir2-block block)) + (let* ((cont (node-cont node)) + (2cont (continuation-info cont)) + (value (cast-value node)) + (2value (continuation-info value))) + (cond ((not 2cont)) + ((eq (ir2-continuation-kind 2cont) :unused)) + ((eq (ir2-continuation-kind 2cont) :unknown) + (aver (eq (ir2-continuation-kind 2value) :unknown)) + (aver (not (cast-type-check node))) + (move-results-coerced node block + (ir2-continuation-locs 2value) + (ir2-continuation-locs 2cont))) + ((eq (ir2-continuation-kind 2cont) :fixed) + (aver (eq (ir2-continuation-kind 2value) :fixed)) + (if (cast-type-check node) + (move-results-checked node block + (ir2-continuation-locs 2value) + (ir2-continuation-locs 2cont) + (multiple-value-bind (check types) + (cast-check-types node nil) + (aver (eq check :simple)) + types)) + (move-results-coerced node block + (ir2-continuation-locs 2value) + (ir2-continuation-locs 2cont)))) + (t (bug "CAST cannot be :DELAYED."))))) ;;;; template conversion -;;; Build a TN-Refs list that represents access to the values of the +;;; Build a TN-REFS list that represents access to the values of the ;;; specified list of continuations ARGS for TEMPLATE. Any :CONSTANT ;;; arguments are returned in the second value as a list rather than ;;; being accessed as a normal argument. NODE and BLOCK provide the @@ -537,13 +562,7 @@ (declare (type combination call) (type continuation cont) (type template template) (list rtypes)) (let* ((dtype (node-derived-type call)) - (type (if (and (or (eq (template-ltn-policy template) :safe) - (policy call (= safety 0))) - (continuation-type-check cont)) - (values-type-intersection - dtype - (continuation-asserted-type cont)) - dtype)) + (type dtype) (types (mapcar #'primitive-type (if (values-type-p type) (append (values-type-required type) @@ -588,7 +607,7 @@ cont (find-template-result-types call cont template rtypes))))) -;;; Get the operands into TNs, make TN-Refs for them, and then call +;;; Get the operands into TNs, make TN-REFs for them, and then call ;;; the template emit function. (defun ir2-convert-template (call block) (declare (type combination call) (type ir2-block block)) @@ -831,12 +850,14 @@ ;;;; full call -;;; Given a function continuation FUN, return as values a TN holding -;;; the thing that we call and true if the thing is named (false if it -;;; is a function). There are two interesting non-named cases: -;;; -- Known to be a function, no check needed: return the -;;; continuation loc. -;;; -- Not known what it is. +;;; Given a function continuation FUN, return (VALUES TN-TO-CALL +;;; NAMED-P), where TN-TO-CALL is a TN holding the thing that we call +;;; NAMED-P is true if the thing is named (false if it is a function). +;;; +;;; There are two interesting non-named cases: +;;; -- We know it's a function. No check needed: return the +;;; continuation LOC. +;;; -- We don't know what it is. (defun fun-continuation-tn (node block cont) (declare (type continuation cont)) (let ((2cont (continuation-info cont))) @@ -846,23 +867,13 @@ (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))) (aver (and (eq (ir2-continuation-kind 2cont) :fixed) (= (length locs) 1))) - (cond ((eq (tn-primitive-type loc) function-ptype) - (aver (not (eq check t))) - (values loc nil)) - (t - (let ((temp (make-normal-tn function-ptype))) - (aver (and (eq (ir2-continuation-primitive-type 2cont) - function-ptype) - (eq check t))) - (emit-type-check node block loc temp - (specifier-type 'function)) - (values temp nil)))))))) - -;;; Set up the args to Node in the current frame, and return a tn-ref + (aver (eq (tn-primitive-type loc) function-ptype)) + (values loc nil))))) + +;;; Set up the args to NODE in the current frame, and return a TN-REF ;;; list for the passing locations. (defun move-tail-full-call-args (node block) (declare (type combination node) (type ir2-block block)) @@ -964,7 +975,7 @@ arg-locs nargs))))) (values)) -;;; stuff to check in CHECK-FULL-CALL +;;; stuff to check in PONDER-FULL-CALL ;;; ;;; There are some things which are intended always to be optimized ;;; away by DEFTRANSFORMs and such, and so never compiled into full @@ -977,7 +988,7 @@ ;;; list. (defvar *always-optimized-away* '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug - ;; reported to cmucl-imp@cons.org 2000-06-20. + ;; reported to cmucl-imp 2000-06-20. %instance-ref ;; These should always turn into VOPs, but wasn't in a bug which ;; appeared when LTN-POLICY stuff was being tweaked in @@ -985,7 +996,7 @@ data-vector-set data-vector-ref)) -;;; more stuff to check in CHECK-FULL-CALL +;;; more stuff to check in PONDER-FULL-CALL ;;; ;;; These came in handy when troubleshooting cold boot after making ;;; major changes in the package structure: various transforms and @@ -997,12 +1008,15 @@ #!+sb-show (defvar *show-full-called-fnames-p* nil) #!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal)) -;;; Do some checks on a full call: +;;; Do some checks (and store some notes relevant for future checks) +;;; on a full call: ;;; * Is this a full call to something we have reason to know should -;;; never be full called? +;;; never be full called? (Except as of sbcl-0.7.18 or so, we no +;;; longer try to ensure this behavior when *FAILURE-P* has already +;;; been detected.) ;;; * Is this a full call to (SETF FOO) which might conflict with ;;; a DEFSETF or some such thing elsewhere in the program? -(defun check-full-call (node) +(defun ponder-full-call (node) (let* ((cont (basic-combination-fun node)) (fname (continuation-fun-name cont t))) (declare (type (or symbol cons) fname)) @@ -1022,15 +1036,22 @@ (basic-combination-args node)))) (/show arg-types))) - (when (memq fname *always-optimized-away*) - (/show (policy node speed) (policy node safety)) - (/show (policy node compilation-speed)) - (bug "full call to ~S" fname)) + ;; When illegal code is compiled, all sorts of perverse paths + ;; through the compiler can be taken, and it's much harder -- and + ;; probably pointless -- to guarantee that always-optimized-away + ;; functions are actually optimized away. Thus, we skip the check + ;; in that case. + (unless *failure-p* + (when (memq fname *always-optimized-away*) + (/show (policy node speed) (policy node safety)) + (/show (policy node compilation-speed)) + (bug "full call to ~S" fname))) (when (consp fname) - (destructuring-bind (setf stem) fname - (aver (eq setf 'setf)) - (setf (gethash stem *setf-assumed-fboundp*) t))))) + (aver (legal-fun-name-p fname)) + (destructuring-bind (setfoid &rest stem) fname + (when (eq setfoid 'setf) + (setf (gethash (car stem) *setf-assumed-fboundp*) t)))))) ;;; If the call is in a tail recursive position and the return ;;; convention is standard, then do a tail full call. If one or fewer @@ -1038,7 +1059,7 @@ ;;; multiple-values call. (defun ir2-convert-full-call (node block) (declare (type combination node) (type ir2-block block)) - (check-full-call node) + (ponder-full-call node) (let ((2cont (continuation-info (node-cont node)))) (cond ((node-tail-p node) (ir2-convert-tail-full-call node block)) @@ -1279,14 +1300,15 @@ (defoptimizer (values-list ir2-convert) ((list) node block) (let* ((cont (node-cont node)) (2cont (continuation-info cont))) - (when 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed (ir2-convert-full-call node block)) - (:unknown - (let ((locs (ir2-continuation-locs 2cont))) - (vop* values-list node block - ((continuation-tn node block list) nil) - ((reference-tn-list locs t))))))))) + (cond ((and 2cont + (eq (ir2-continuation-kind 2cont) :unknown)) + (let ((locs (ir2-continuation-locs 2cont))) + (vop* values-list node block + ((continuation-tn node block list) nil) + ((reference-tn-list locs t))))) + (t (aver (or (not 2cont) ; i.e. we want to check the argument + (eq (ir2-continuation-kind 2cont) :fixed))) + (ir2-convert-full-call node block))))) (defoptimizer (%more-arg-values ir2-convert) ((context start count) node block) (let* ((cont (node-cont node)) @@ -1321,15 +1343,27 @@ (def-ir1-translator progv ((vars vals &body body) start cont) (ir1-convert start cont - (once-only ((n-save-bs '(%primitive current-binding-pointer))) - `(unwind-protect - (progn - (mapc (lambda (var val) - (%primitive bind val var)) - ,vars - ,vals) - ,@body) - (%primitive unbind-to-here ,n-save-bs))))) + (with-unique-names (bind unbind) + (once-only ((n-save-bs '(%primitive current-binding-pointer))) + `(unwind-protect + (progn + (labels ((,unbind (vars) + (declare (optimize (speed 2) (debug 0))) + (dolist (var vars) + (%primitive bind nil var) + (makunbound 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)))))) + (,bind ,vars ,vals)) + nil + ,@body) + (%primitive unbind-to-here ,n-save-bs)))))) ;;;; non-local exit @@ -1569,7 +1603,7 @@ (last (block-last block)) (succ (block-succ block))) (unless (if-p last) - (aver (and succ (null (rest succ)))) + (aver (singleton-p succ)) (let ((target (first succ))) (cond ((eq target (component-tail (block-component block))) (when (and (basic-combination-p last) @@ -1631,6 +1665,8 @@ (ir2-convert-return node 2block)) (cset (ir2-convert-set node 2block)) + (cast + (ir2-convert-cast node 2block)) (mv-combination (cond ((eq (basic-combination-kind node) :local)