X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=b5643899bf3098891947b47a8a3545c8b3e3709e;hb=c7de1989d006e0b3a4f26143b7a81c9bdb754101;hp=b916025a110f1eb3c4a71577036f24c1f783f3dd;hpb=cf6f2e4b33475c59d999e53d3d5c290726fe0a7c;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index b916025..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. @@ -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,6 +461,37 @@ ((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 @@ -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) @@ -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 @@ -1333,8 +1343,7 @@ (def-ir1-translator progv ((vars vals &body body) start cont) (ir1-convert start cont - (let ((bind (gensym "BIND")) - (unbind (gensym "UNBIND"))) + (with-unique-names (bind unbind) (once-only ((n-save-bs '(%primitive current-binding-pointer))) `(unwind-protect (progn @@ -1347,7 +1356,9 @@ (declare (optimize (speed 2) (debug 0))) (cond ((null vars)) ((null vals) (,unbind vars)) - (t (%primitive bind (car vals) (car vars)) + (t (%primitive bind + (car vals) + (car vars)) (,bind (cdr vars) (cdr vals)))))) (,bind ,vars ,vals)) nil @@ -1592,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) @@ -1654,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)