X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=b5643899bf3098891947b47a8a3545c8b3e3709e;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=59942390a75717cc891ca9779caefddd1b8ebd58;hpb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 5994239..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 nil) - (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 nil) - (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. @@ -1594,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) @@ -1656,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)