X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=b5643899bf3098891947b47a8a3545c8b3e3709e;hb=eb6f8dd033501c7372b27967a2cb7750560897bd;hp=0243abcdf73a7720ed5cc7df5274f55d7c8fc94a;hpb=9728093863d1ed201719d1f7ef61b9df29bb1d44;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 0243abc..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)) @@ -848,21 +867,11 @@ (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)))))))) + (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. @@ -1039,9 +1048,10 @@ (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 @@ -1290,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)) @@ -1332,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 @@ -1580,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) @@ -1642,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)