Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8-pr-cvs1:/tmp/cvs-serv6208/src/compiler Modified Files: aliencomp.lisp array-tran.lisp checkgen.lisp constraint.lisp control.lisp ctype.lisp debug-dump.lisp debug.lisp dfo.lisp float-tran.lisp gtn.lisp ir1-translators.lisp ir1final.lisp ir1opt.lisp ir1report.lisp ir1tran-lambda.lisp ir1tran.lisp ir1util.lisp ir2tran.lisp knownfun.lisp locall.lisp ltn.lisp ltv.lisp macros.lisp main.lisp node.lisp physenvanal.lisp saptran.lisp seqtran.lisp srctran.lisp stack.lisp typetran.lisp vop.lisp Log Message: 0.8.3.62: * Split CONTINUATION into CTRAN (control part) and LVAR (value part); ... remove :DELETED and :DELETED-BLOCK-START continuation kinds; ... remove bug reported by Paul Dietz on sbcl-devel 2003-09-14. Index: aliencomp.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/aliencomp.lisp,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- aliencomp.lisp 27 May 2003 08:35:53 -0000 1.15 +++ aliencomp.lisp 15 Sep 2003 09:21:38 -0000 1.16 @@ -86,16 +86,16 @@ ;;;; SLOT support (defun find-slot-offset-and-type (alien slot) - (unless (constant-continuation-p slot) + (unless (constant-lvar-p slot) (give-up-ir1-transform "The slot is not constant, so access cannot be open coded.")) - (let ((type (continuation-type alien))) + (let ((type (lvar-type alien))) (unless (alien-type-type-p type) (give-up-ir1-transform)) (let ((alien-type (alien-type-type-alien-type type))) (unless (alien-record-type-p alien-type) (give-up-ir1-transform)) - (let* ((slot-name (continuation-value slot)) + (let* ((slot-name (lvar-value slot)) (field (find slot-name (alien-record-type-fields alien-type) :key #'alien-record-field-name))) (unless field @@ -130,7 +130,7 @@ (find-slot-offset-and-type alien slot) (declare (ignore slot-offset)) (let ((type (make-alien-type-type slot-type))) - (assert-continuation-type value type) + (assert-lvar-type value type) (return type)))) *wild-type*)) @@ -162,7 +162,7 @@ ;;;; DEREF support (defun find-deref-alien-type (alien) - (let ((alien-type (continuation-type alien))) + (let ((alien-type (lvar-type alien))) (unless (alien-type-type-p alien-type) (give-up-ir1-transform)) (let ((alien-type (alien-type-type-alien-type alien-type))) @@ -252,7 +252,7 @@ (let ((type (make-alien-type-type (make-alien-pointer-type :to (find-deref-element-type alien))))) - (assert-continuation-type value type) + (assert-lvar-type value type) (return type))) *wild-type*)) @@ -285,9 +285,9 @@ ;;;; support for aliens on the heap (defun heap-alien-sap-and-type (info) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (give-up-ir1-transform "info not constant; can't open code")) - (let ((info (continuation-value info))) + (let ((info (lvar-value info))) (values (heap-alien-info-sap-form info) (heap-alien-info-type info)))) @@ -311,7 +311,7 @@ (multiple-value-bind (sap type) (heap-alien-sap-and-type info) (declare (ignore sap)) (let ((type (make-alien-type-type type))) - (assert-continuation-type value type) + (assert-lvar-type value type) (return type)))) *wild-type*)) @@ -335,9 +335,9 @@ ;;;; support for local (stack or register) aliens (deftransform make-local-alien ((info) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info)) (bits (alien-type-bits alien-type))) (unless bits @@ -370,13 +370,13 @@ (deftransform note-local-alien-type ((info var) * * :important t) ;; FIXME: This test and error occur about a zillion times. They ;; could be factored into a function. - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let ((info (continuation-value info))) + (let ((info (lvar-value info))) (/noshow "in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info) (/noshow (local-alien-info-force-to-memory-p info)) (unless (local-alien-info-force-to-memory-p info) - (let ((var-node (continuation-use var))) + (let ((var-node (lvar-uses var))) (/noshow var-node (ref-p var-node)) (when (ref-p var-node) (propagate-to-refs (ref-leaf var-node) @@ -386,9 +386,9 @@ nil) (deftransform local-alien ((info var) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type) (/noshow (local-alien-info-force-to-memory-p info)) @@ -397,31 +397,31 @@ `(naturalize var ',alien-type)))) (deftransform %local-alien-forced-to-memory-p ((info) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let ((info (continuation-value info))) + (let ((info (lvar-value info))) (local-alien-info-force-to-memory-p info))) (deftransform %set-local-alien ((info var value) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (if (local-alien-info-force-to-memory-p info) `(deposit-alien-value var 0 ',alien-type value) '(error "This should be eliminated as dead code.")))) (defoptimizer (%local-alien-addr derive-type) ((info var)) - (if (constant-continuation-p info) - (let* ((info (continuation-value info)) + (if (constant-lvar-p info) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (make-alien-type-type (make-alien-pointer-type :to alien-type))) *wild-type*)) (deftransform %local-alien-addr ((info var) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN") (if (local-alien-info-force-to-memory-p info) @@ -429,9 +429,9 @@ (error "This shouldn't happen.")))) (deftransform dispose-local-alien ((info var) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (if (local-alien-info-force-to-memory-p info) #!+x86 `(%primitive dealloc-alien-stack-space @@ -445,17 +445,17 @@ ;;;; %CAST (defoptimizer (%cast derive-type) ((alien type)) - (or (when (constant-continuation-p type) - (let ((alien-type (continuation-value type))) + (or (when (constant-lvar-p type) + (let ((alien-type (lvar-value type))) (when (alien-type-p alien-type) (make-alien-type-type alien-type)))) *wild-type*)) (deftransform %cast ((alien target-type) * * :important t) - (unless (constant-continuation-p target-type) + (unless (constant-lvar-p target-type) (give-up-ir1-transform "The alien type is not constant, so access cannot be open coded.")) - (let ((target-type (continuation-value target-type))) + (let ((target-type (lvar-value target-type))) (cond ((or (alien-pointer-type-p target-type) (alien-array-type-p target-type) (alien-fun-type-p target-type)) @@ -466,7 +466,7 @@ ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc. (deftransform alien-sap ((alien) * * :important t) - (let ((alien-node (continuation-use alien))) + (let ((alien-node (lvar-uses alien))) (typecase alien-node (combination (extract-fun-args alien '%sap-alien 2) @@ -478,8 +478,8 @@ (defoptimizer (%sap-alien derive-type) ((sap type)) (declare (ignore sap)) - (if (constant-continuation-p type) - (make-alien-type-type (continuation-value type)) + (if (constant-lvar-p type) + (make-alien-type-type (lvar-value type)) *wild-type*)) (deftransform %sap-alien ((sap type) * * :important t) @@ -493,12 +493,12 @@ (flet ((%computed-lambda (compute-lambda type) (declare (type function compute-lambda)) - (unless (constant-continuation-p type) + (unless (constant-lvar-p type) (give-up-ir1-transform "The type is not constant at compile time; can't open code.")) (handler-case - (let ((result (funcall compute-lambda (continuation-value type)))) - (/noshow "in %COMPUTED-LAMBDA" (continuation-value type) result) + (let ((result (funcall compute-lambda (lvar-value type)))) + (/noshow "in %COMPUTED-LAMBDA" (lvar-value type) result) result) (error (condition) (compiler-error "~A" condition))))) @@ -515,33 +515,33 @@ (defun count-low-order-zeros (thing) (typecase thing - (continuation - (if (constant-continuation-p thing) - (count-low-order-zeros (continuation-value thing)) - (count-low-order-zeros (continuation-use thing)))) + (lvar + (if (constant-lvar-p thing) + (count-low-order-zeros (lvar-value thing)) + (count-low-order-zeros (lvar-uses thing)))) (combination - (case (continuation-fun-name (combination-fun thing)) + (case (lvar-fun-name (combination-fun thing)) ((+ -) (let ((min most-positive-fixnum) (itype (specifier-type 'integer))) (dolist (arg (combination-args thing) min) - (if (csubtypep (continuation-type arg) itype) + (if (csubtypep (lvar-type arg) itype) (setf min (min min (count-low-order-zeros arg))) (return 0))))) (* (let ((result 0) (itype (specifier-type 'integer))) (dolist (arg (combination-args thing) result) - (if (csubtypep (continuation-type arg) itype) + (if (csubtypep (lvar-type arg) itype) (setf result (+ result (count-low-order-zeros arg))) (return 0))))) (ash (let ((args (combination-args thing))) (if (= (length args) 2) (let ((amount (second args))) - (if (constant-continuation-p amount) + (if (constant-lvar-p amount) (max (+ (count-low-order-zeros (first args)) - (continuation-value amount)) + (lvar-value amount)) 0) 0)) 0))) @@ -557,9 +557,9 @@ 0))) (deftransform / ((numerator denominator) (integer integer)) - (unless (constant-continuation-p denominator) + (unless (constant-lvar-p denominator) (give-up-ir1-transform)) - (let* ((denominator (continuation-value denominator)) + (let* ((denominator (lvar-value denominator)) (bits (1- (integer-length denominator)))) (unless (= (ash 1 bits) denominator) (give-up-ir1-transform)) @@ -569,17 +569,17 @@ `(ash numerator ,(- bits))))) (deftransform ash ((value amount)) - (let ((value-node (continuation-use value))) + (let ((value-node (lvar-uses value))) (unless (and (combination-p value-node) - (eq (continuation-fun-name (combination-fun value-node)) + (eq (lvar-fun-name (combination-fun value-node)) 'ash)) (give-up-ir1-transform)) (let ((inside-args (combination-args value-node))) (unless (= (length inside-args) 2) (give-up-ir1-transform)) (let ((inside-amount (second inside-args))) - (unless (and (constant-continuation-p inside-amount) - (not (minusp (continuation-value inside-amount)))) + (unless (and (constant-lvar-p inside-amount) + (not (minusp (lvar-value inside-amount)))) (give-up-ir1-transform))))) (extract-fun-args value 'ash 2) '(lambda (value amount1 amount2) @@ -596,7 +596,7 @@ (alien-funcall (deref function) ,@names)))) (deftransform alien-funcall ((function &rest args) * * :important t) - (let ((type (continuation-type function))) + (let ((type (lvar-type function))) (unless (alien-type-type-p type) (give-up-ir1-transform "can't tell function type at compile time")) (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL" function) @@ -634,9 +634,9 @@ (defoptimizer (%alien-funcall derive-type) ((function type &rest args)) (declare (ignore function args)) - (unless (constant-continuation-p type) + (unless (constant-lvar-p type) (error "Something is broken.")) - (let ((type (continuation-value type))) + (let ((type (lvar-value type))) (unless (alien-fun-type-p type) (error "Something is broken.")) (values-specifier-type @@ -647,16 +647,16 @@ ((function type &rest args) node ltn-policy) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil) - (annotate-ordinary-continuation function) + (annotate-ordinary-lvar function) (dolist (arg args) - (annotate-ordinary-continuation arg))) + (annotate-ordinary-lvar arg))) (defoptimizer (%alien-funcall ir2-convert) ((function type &rest args) call block) - (let ((type (if (constant-continuation-p type) - (continuation-value type) + (let ((type (if (constant-lvar-p type) + (lvar-value type) (error "Something is broken."))) - (cont (node-cont call)) + (lvar (node-lvar call)) (args args)) (multiple-value-bind (nsp stack-frame-size arg-tns result-tns) (make-call-out-tns type) @@ -674,13 +674,13 @@ #!+x86 (emit-move-arg-template call block (first move-arg-vops) - (continuation-tn call block arg) + (lvar-tn call block arg) nsp tn) #!-x86 (progn (emit-move call block - (continuation-tn call block arg) + (lvar-tn call block arg) temp-tn) (emit-move-arg-template call block @@ -692,8 +692,8 @@ (unless (listp result-tns) (setf result-tns (list result-tns))) (vop* call-out call block - ((continuation-tn call block function) + ((lvar-tn call block function) (reference-tn-list arg-tns nil)) ((reference-tn-list result-tns t))) (vop dealloc-number-stack-space call block stack-frame-size) - (move-continuation-result call block result-tns cont)))) + (move-lvar-result call block result-tns lvar)))) Index: array-tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v retrieving revision 1.58 retrieving revision 1.59 diff -u -d -r1.58 -r1.59 --- array-tran.lisp 3 Aug 2003 11:32:29 -0000 1.58 +++ array-tran.lisp 15 Sep 2003 09:21:38 -0000 1.59 @@ -13,11 +13,11 @@ ;;;; utilities for optimizing array operations -;;; Return UPGRADED-ARRAY-ELEMENT-TYPE for CONTINUATION, or do +;;; Return UPGRADED-ARRAY-ELEMENT-TYPE for LVAR, or do ;;; GIVE-UP-IR1-TRANSFORM if the upgraded element type can't be ;;; determined. -(defun upgraded-element-type-specifier-or-give-up (continuation) - (let* ((element-ctype (extract-upgraded-element-type continuation)) +(defun upgraded-element-type-specifier-or-give-up (lvar) + (let* ((element-ctype (extract-upgraded-element-type lvar)) (element-type-specifier (type-specifier element-ctype))) (if (eq element-type-specifier '*) (give-up-ir1-transform @@ -27,7 +27,7 @@ ;;; Array access functions return an object from the array, hence its ;;; type is going to be the array upgraded element type. (defun extract-upgraded-element-type (array) - (let ((type (continuation-type array))) + (let ((type (lvar-type array))) ;; Note that this IF mightn't be satisfied even if the runtime ;; value is known to be a subtype of some specialized ARRAY, because ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE), @@ -42,7 +42,7 @@ *wild-type*))) (defun extract-declared-element-type (array) - (let ((type (continuation-type array))) + (let ((type (lvar-type array))) (if (array-type-p type) (array-type-element-type type) *wild-type*))) @@ -51,39 +51,39 @@ ;;; return type is going to be the same as the new-value for SETF ;;; functions. (defun assert-new-value-type (new-value array) - (let ((type (continuation-type array))) + (let ((type (lvar-type array))) (when (array-type-p type) - (assert-continuation-type + (assert-lvar-type new-value (array-type-specialized-element-type type) - (lexenv-policy (node-lexenv (continuation-dest new-value)))))) - (continuation-type new-value)) + (lexenv-policy (node-lexenv (lvar-dest new-value)))))) + (lvar-type new-value)) (defun assert-array-complex (array) - (assert-continuation-type + (assert-lvar-type array (make-array-type :complexp t :element-type *wild-type*) - (lexenv-policy (node-lexenv (continuation-dest array)))) + (lexenv-policy (node-lexenv (lvar-dest array)))) nil) -;;; Return true if ARG is NIL, or is a constant-continuation whose +;;; Return true if ARG is NIL, or is a constant-lvar whose ;;; value is NIL, false otherwise. (defun unsupplied-or-nil (arg) - (declare (type (or continuation null) arg)) + (declare (type (or lvar null) arg)) (or (not arg) - (and (constant-continuation-p arg) - (not (continuation-value arg))))) + (and (constant-lvar-p arg) + (not (lvar-value arg))))) ;;;; DERIVE-TYPE optimizers ;;; Array operations that use a specific number of indices implicitly ;;; assert that the array is of that rank. (defun assert-array-rank (array rank) - (assert-continuation-type + (assert-lvar-type array (specifier-type `(array * ,(make-list rank :initial-element '*))) - (lexenv-policy (node-lexenv (continuation-dest array))))) + (lexenv-policy (node-lexenv (lvar-dest array))))) (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) @@ -110,7 +110,7 @@ ;;; Figure out the type of the data vector if we know the argument ;;; element type. (defoptimizer (%with-array-data derive-type) ((array start end)) - (let ((atype (continuation-type array))) + (let ((atype (lvar-type array))) (when (array-type-p atype) (specifier-type `(simple-array ,(type-specifier @@ -136,22 +136,22 @@ (or (careful-specifier-type `(,(if simple 'simple-array 'array) ,(cond ((not element-type) t) - ((constant-continuation-p element-type) + ((constant-lvar-p element-type) (let ((ctype (careful-specifier-type - (continuation-value element-type)))) + (lvar-value element-type)))) (cond ((or (null ctype) (unknown-type-p ctype)) '*) (t (sb!xc:upgraded-array-element-type - (continuation-value element-type)))))) + (lvar-value element-type)))))) (t '*)) - ,(cond ((constant-continuation-p dims) - (let* ((val (continuation-value dims)) + ,(cond ((constant-lvar-p dims) + (let* ((val (lvar-value dims)) (cdims (if (listp val) val (list val)))) (if simple cdims (length cdims)))) - ((csubtypep (continuation-type dims) + ((csubtypep (lvar-type dims) (specifier-type 'integer)) '(*)) (t @@ -209,11 +209,11 @@ (when (null initial-element) (give-up-ir1-transform)) (let* ((eltype (cond ((not element-type) t) - ((not (constant-continuation-p element-type)) + ((not (constant-lvar-p element-type)) (give-up-ir1-transform "ELEMENT-TYPE is not constant.")) (t - (continuation-value element-type)))) + (lvar-value element-type)))) (eltype-type (ir1-transform-specifier-type eltype)) (saetp (find-if (lambda (saetp) (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) @@ -228,16 +228,16 @@ (unless saetp (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype)) - (cond ((and (constant-continuation-p initial-element) - (eql (continuation-value initial-element) + (cond ((and (constant-lvar-p initial-element) + (eql (lvar-value initial-element) (sb!vm:saetp-initial-element-default saetp))) creation-form) (t ;; error checking for target, disabled on the host because ;; (CTYPE-OF #\Null) is not possible. #-sb-xc-host - (when (constant-continuation-p initial-element) - (let ((value (continuation-value initial-element))) + (when (constant-lvar-p initial-element) + (let ((value (lvar-value initial-element))) (cond ((not (ctypep value (sb!vm:saetp-ctype saetp))) ;; this case will cause an error at runtime, so we'd @@ -266,13 +266,13 @@ (deftransform make-array ((length &key element-type) (integer &rest *)) (let* ((eltype (cond ((not element-type) t) - ((not (constant-continuation-p element-type)) + ((not (constant-lvar-p element-type)) (give-up-ir1-transform "ELEMENT-TYPE is not constant.")) (t - (continuation-value element-type)))) - (len (if (constant-continuation-p length) - (continuation-value length) + (lvar-value element-type)))) + (len (if (constant-lvar-p length) + (lvar-value length) '*)) (eltype-type (ir1-transform-specifier-type eltype)) (result-type-spec @@ -338,13 +338,13 @@ ;;; CSR, 2002-07-01 (deftransform make-array ((dims &key element-type) (list &rest *)) - (unless (or (null element-type) (constant-continuation-p element-type)) + (unless (or (null element-type) (constant-lvar-p element-type)) (give-up-ir1-transform "The element-type is not constant; cannot open code array creation.")) - (unless (constant-continuation-p dims) + (unless (constant-lvar-p dims) (give-up-ir1-transform "The dimension list is not constant; cannot open code array creation.")) - (let ((dims (continuation-value dims))) + (let ((dims (lvar-value dims))) (unless (every #'integerp dims) (give-up-ir1-transform "The dimension list contains something other than an integer: ~S" @@ -357,11 +357,11 @@ (rank (length dims)) (spec `(simple-array ,(cond ((null element-type) t) - ((and (constant-continuation-p element-type) + ((and (constant-lvar-p element-type) (ir1-transform-specifier-type - (continuation-value element-type))) + (lvar-value element-type))) (sb!xc:upgraded-array-element-type - (continuation-value element-type))) + (lvar-value element-type))) (t '*)) ,(make-list rank :initial-element '*)))) `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))) @@ -387,7 +387,7 @@ ;;; If we can tell the rank from the type info, use it instead. (deftransform array-rank ((array)) - (let ((array-type (continuation-type array))) + (let ((array-type (lvar-type array))) (unless (array-type-p array-type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions array-type))) @@ -403,10 +403,10 @@ ;;; (if it's simple and a vector). (deftransform array-dimension ((array axis) (array index)) - (unless (constant-continuation-p axis) + (unless (constant-lvar-p axis) (give-up-ir1-transform "The axis is not constant.")) - (let ((array-type (continuation-type array)) - (axis (continuation-value axis))) + (let ((array-type (lvar-type array)) + (axis (lvar-value axis))) (unless (array-type-p array-type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions array-type))) @@ -435,7 +435,7 @@ ;;; If the length has been declared and it's simple, just return it. (deftransform length ((vector) ((simple-array * (*)))) - (let ((type (continuation-type vector))) + (let ((type (lvar-type vector))) (unless (array-type-p type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions type))) @@ -454,7 +454,7 @@ ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a ;;; compile-time constant. (deftransform vector-length ((vector)) - (let ((vtype (continuation-type vector))) + (let ((vtype (lvar-type vector))) (if (and (array-type-p vtype) (not (array-type-complexp vtype))) (let ((dim (first (array-type-dimensions vtype)))) @@ -469,7 +469,7 @@ ;;; INDEX. (deftransform array-total-size ((array) (array)) - (let ((array-type (continuation-type array))) + (let ((array-type (lvar-type array))) (unless (array-type-p array-type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions array-type))) @@ -484,7 +484,7 @@ ;;; Only complex vectors have fill pointers. (deftransform array-has-fill-pointer-p ((array)) - (let ((array-type (continuation-type array))) + (let ((array-type (lvar-type array))) (unless (array-type-p array-type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions array-type))) @@ -506,10 +506,10 @@ (deftransform %check-bound ((array dimension index) * * :node node) (cond ((policy node (and (> speed safety) (= safety 0))) 'index) - ((not (constant-continuation-p dimension)) + ((not (constant-lvar-p dimension)) (give-up-ir1-transform)) (t - (let ((dim (continuation-value dimension))) + (let ((dim (lvar-value dimension))) `(the (integer 0 (,dim)) index))))) ;;;; WITH-ARRAY-DATA @@ -756,7 +756,7 @@ ;;; Pick off some constant cases. (defoptimizer (array-header-p derive-type) ((array)) - (let ((type (continuation-type array))) + (let ((type (lvar-type array))) (cond ((not (array-type-p type)) nil) (t Index: checkgen.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v retrieving revision 1.38 retrieving revision 1.39 diff -u -d -r1.38 -r1.39 --- checkgen.lisp 30 Aug 2003 06:44:45 -0000 1.38 +++ checkgen.lisp 15 Sep 2003 09:21:38 -0000 1.39 @@ -160,10 +160,10 @@ ;;; FIXME: I don't quite understand this, but it looks as though ;;; that means type checks are weakened when SPEED=3 regardless of ;;; the SAFETY level, which is not the right thing to do. -(defun maybe-negate-check (cont types original-types force-hairy) - (declare (type continuation cont) (list types)) +(defun maybe-negate-check (lvar types original-types force-hairy) + (declare (type lvar lvar) (list types)) (multiple-value-bind (ptypes count) - (no-fun-values-types (continuation-derived-type cont)) + (no-fun-values-types (lvar-derived-type lvar)) (if (eq count :unknown) (if (and (every #'type-check-template types) (not force-hairy)) (values :simple types) @@ -220,12 +220,12 @@ ;;; negation of this type instead. (defun cast-check-types (cast force-hairy) (declare (type cast cast)) - (let* ((cont (node-cont cast)) - (ctype (coerce-to-values (cast-type-to-check cast))) + (let* ((ctype (coerce-to-values (cast-type-to-check cast))) (atype (coerce-to-values (cast-asserted-type cast))) (value (cast-value cast)) - (vtype (continuation-derived-type value)) - (dest (continuation-dest cont))) + (vtype (lvar-derived-type value)) + (lvar (node-lvar cast)) + (dest (and lvar (lvar-dest lvar)))) (aver (not (eq ctype *wild-type*))) (multiple-value-bind (ctypes count) (no-fun-values-types ctype) (multiple-value-bind (atypes acount) (no-fun-values-types atype) @@ -241,10 +241,10 @@ (eq count :unknown)))) (maybe-negate-check value ctypes atypes t) (maybe-negate-check value ctypes atypes force-hairy))) - ((and (continuation-single-value-p cont) + ((and (lvar-single-value-p lvar) (or (not (args-type-rest ctype)) (eq (args-type-rest ctype) *universal-type*))) - (principal-continuation-single-valuify cont) + (principal-lvar-single-valuify lvar) (let ((creq (car (args-type-required ctype)))) (multiple-value-setq (ctype atype) (if creq @@ -256,7 +256,7 @@ force-hairy))) ((and (mv-combination-p dest) (eq (mv-combination-kind dest) :local)) - (let* ((fun-ref (continuation-use (mv-combination-fun dest))) + (let* ((fun-ref (lvar-use (mv-combination-fun dest))) (length (length (lambda-vars (ref-leaf fun-ref))))) (maybe-negate-check value ;; FIXME @@ -278,8 +278,8 @@ ;;; Do we want to do a type check? (defun worth-type-check-p (cast) (declare (type cast cast)) - (let* ((cont (node-cont cast)) - (dest (continuation-dest cont))) + (let* ((lvar (node-lvar cast)) + (dest (and lvar (lvar-dest lvar)))) (cond ((not (cast-type-check cast)) nil) ((and (combination-p dest) @@ -294,8 +294,8 @@ ;; recompile all calls to a function when they ;; were originally compiled with a bad ;; declaration. (See also bug 35.) - (immediately-used-p cont cast) - (values-subtypep (continuation-externally-checkable-type cont) + (immediately-used-p lvar cast) + (values-subtypep (lvar-externally-checkable-type lvar) (cast-type-to-check cast))) nil) (t @@ -313,8 +313,8 @@ ;;; compatible with the call's type. (defun probable-type-check-p (cast) (declare (type cast cast)) - (let* ((cont (node-cont cast)) - (dest (continuation-dest cont))) + (let* ((lvar (node-lvar cast)) + (dest (and lvar (lvar-dest lvar)))) (cond ((not dest) nil) (t t)) #+nil @@ -376,10 +376,10 @@ ;;; passes them on to CONT. (defun convert-type-check (cast types) (declare (type cast cast) (type list types)) - (let ((cont (cast-value cast)) + (let ((value (cast-value cast)) (length (length types))) - (filter-continuation cont (make-type-check-form types)) - (reoptimize-continuation (cast-value cast)) + (filter-lvar value (make-type-check-form types)) + (reoptimize-lvar (cast-value cast)) (setf (cast-type-to-check cast) *wild-type*) (setf (cast-%type-check cast) nil) (let* ((atype (cast-asserted-type cast)) @@ -404,8 +404,8 @@ ;;; the value is a constant, we print it specially. (defun cast-check-uses (cast) (declare (type cast cast)) - (let* ((cont (node-cont cast)) - (dest (continuation-dest cont)) + (let* ((lvar (node-lvar cast)) + (dest (and lvar (lvar-dest lvar))) (value (cast-value cast)) (atype (cast-asserted-type cast))) (do-uses (use value) @@ -417,9 +417,9 @@ (eq (combination-kind dest) :local)) (let ((lambda (combination-lambda dest)) (pos (position-or-lose - cont (combination-args dest)))) + lvar (combination-args dest)))) (format nil "~:[A possible~;The~] binding of ~S" - (and (continuation-use cont) + (and (lvar-has-single-use-p lvar) (eq (functional-kind lambda) :let)) (leaf-source-name (elt (lambda-vars lambda) pos))))))) @@ -465,7 +465,7 @@ (collect ((casts)) (do-blocks (block component) (when (block-type-check block) - (do-nodes (node cont block) + (do-nodes (node nil block) (when (and (cast-p node) (cast-type-check node)) (cast-check-uses node) Index: constraint.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/constraint.lisp,v retrieving revision 1.20 retrieving revision 1.21 diff -u -d -r1.20 -r1.21 --- constraint.lisp 29 Aug 2003 12:45:46 -0000 1.20 +++ constraint.lisp 15 Sep 2003 09:21:38 -0000 1.21 @@ -120,12 +120,12 @@ (lambda-var-constraints leaf)) leaf))) -;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE, +;;; If LVAR's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE, ;;; otherwise NIL. -#!-sb-fluid (declaim (inline ok-cont-lambda-var)) -(defun ok-cont-lambda-var (cont) - (declare (type continuation cont)) - (let ((use (continuation-use cont))) +#!-sb-fluid (declaim (inline ok-lvar-lambda-var)) +(defun ok-lvar-lambda-var (lvar) + (declare (type lvar lvar)) + (let ((use (lvar-uses lvar))) (when (ref-p use) (ok-ref-lambda-var use)))) @@ -169,49 +169,49 @@ (combination (unless (eq (combination-kind use) :error) - (let ((name (continuation-fun-name + (let ((name (lvar-fun-name (basic-combination-fun use))) (args (basic-combination-args use))) (case name ((%typep %instance-typep) (let ((type (second args))) - (when (constant-continuation-p type) - (let ((val (continuation-value type))) + (when (constant-lvar-p type) + (let ((val (lvar-value type))) (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) + (ok-lvar-lambda-var (first args)) (if (ctype-p val) val (specifier-type val)) nil))))) ((eq eql) - (let* ((var1 (ok-cont-lambda-var (first args))) + (let* ((var1 (ok-lvar-lambda-var (first args))) (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) + (var2 (ok-lvar-lambda-var arg2))) (cond ((not var1)) (var2 (add-complement-constraints if 'eql var1 var2 nil)) - ((constant-continuation-p arg2) + ((constant-lvar-p arg2) (add-complement-constraints if 'eql var1 (ref-leaf - (continuation-use arg2)) + (lvar-uses arg2)) nil))))) ((< >) (let* ((arg1 (first args)) - (var1 (ok-cont-lambda-var arg1)) + (var1 (ok-lvar-lambda-var arg1)) (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) + (var2 (ok-lvar-lambda-var arg2))) (when var1 - (add-complement-constraints if name var1 (continuation-type arg2) + (add-complement-constraints if name var1 (lvar-type arg2) nil)) (when var2 (add-complement-constraints if (if (eq name '<) '> '<) - var2 (continuation-type arg1) + var2 (lvar-type arg1) nil)))) (t (let ((ptype (gethash name *backend-predicate-types*))) (when ptype (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) + (ok-lvar-lambda-var (first args)) ptype nil))))))))) (values)) @@ -221,8 +221,8 @@ (declare (type cblock block)) (let ((last (block-last block))) (when (if-p last) - (let ((use (continuation-use (if-test last)))) - (when use + (let ((use (lvar-uses (if-test last)))) + (when (node-p use) (add-test-constraints use last))))) (setf (block-test-modified block) nil) @@ -371,17 +371,15 @@ (constrain-float-type res y greater not-p))))) ))))) - (let* ((cont (node-cont ref)) - (dest (continuation-dest cont))) - (cond ((and (if-p dest) - (csubtypep (specifier-type 'null) not-res)) - (setf (node-derived-type ref) *wild-type*) - (change-ref-leaf ref (find-constant t))) - (t - (derive-node-type ref - (make-single-value-type - (or (type-difference res not-res) - res)))))))) + (cond ((and (if-p (node-dest ref)) + (csubtypep (specifier-type 'null) not-res)) + (setf (node-derived-type ref) *wild-type*) + (change-ref-leaf ref (find-constant t))) + (t + (derive-node-type ref + (make-single-value-type + (or (type-difference res not-res) + res))))))) (values)) @@ -404,13 +402,12 @@ (when test (sset-union gen test))) - (do-nodes (node cont block) + (do-nodes (node lvar block) (typecase node (bind (let ((fun (bind-lambda node))) (when (eq (functional-kind fun) :let) - (loop with call = (continuation-dest - (node-cont (first (lambda-refs fun)))) + (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun)))) for var in (lambda-vars fun) and val in (combination-args call) when (and val @@ -418,7 +415,7 @@ ;; if VAR has no SETs, type inference is ;; fully performed by IR1 optimizer (lambda-var-sets var)) - do (let* ((type (continuation-type val)) + do (let* ((type (lvar-type val)) (con (find-constraint 'typep var type nil))) (sset-adjoin con gen)))))) (ref @@ -426,7 +423,7 @@ (when var (when ref-preprocessor (funcall ref-preprocessor node gen)) - (let ((dest (continuation-dest cont))) + (let ((dest (and lvar (lvar-dest lvar)))) (when (cast-p dest) (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME (con (find-constraint 'typep var atype nil))) Index: control.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/control.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- control.lisp 14 Dec 2002 22:10:10 -0000 1.9 +++ control.lisp 15 Sep 2003 09:21:38 -0000 1.10 @@ -200,7 +200,7 @@ (do-blocks (block component) (unless (block-flag block) - (event control-deleted-block (continuation-next (block-start block))) + (event control-deleted-block (block-start-node block)) (delete-block block)))) (let ((2comp (component-info component))) Index: ctype.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ctype.lisp,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- ctype.lisp 30 Aug 2003 06:44:45 -0000 1.27 +++ ctype.lisp 15 Sep 2003 09:21:38 -0000 1.28 @@ -171,18 +171,18 @@ (*unwinnage-detected* (values nil nil)) (t (values t t))))) -;;; Check that the derived type of the continuation CONT is compatible -;;; with TYPE. N is the arg number, for error message purposes. We -;;; return true if arg is definitely o.k. If the type is a magic -;;; CONSTANT-TYPE, then we check for the argument being a constant -;;; value of the specified type. If there is a manifest type error -;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even -;;; when our type is satisfied under the test. -(defun check-arg-type (cont type n) - (declare (type continuation cont) (type ctype type) (type index n)) +;;; Check that the derived type of the LVAR is compatible with TYPE. N +;;; is the arg number, for error message purposes. We return true if +;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then +;;; we check for the argument being a constant value of the specified +;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then +;;; we flame about the asserted type even when our type is satisfied +;;; under the test. +(defun check-arg-type (lvar type n) + (declare (type lvar lvar) (type ctype type) (type index n)) (cond ((not (constant-type-p type)) - (let ((ctype (continuation-type cont))) + (let ((ctype (lvar-type lvar))) (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type) (cond ((not win) (note-unwinnage "can't tell whether the ~:R argument is a ~S" @@ -196,11 +196,11 @@ (note-unwinnage "The ~:R argument never returns a value." n) nil) (t t))))) - ((not (constant-continuation-p cont)) + ((not (constant-lvar-p lvar)) (note-unwinnage "The ~:R argument is not a constant." n) nil) (t - (let ((val (continuation-value cont)) + (let ((val (lvar-value lvar)) (type (constant-type-type type))) (multiple-value-bind (res win) (ctypep val type) (cond ((not win) @@ -244,12 +244,12 @@ (let ((k (car key))) (cond ((not (check-arg-type k (specifier-type 'symbol) n))) - ((not (constant-continuation-p k)) + ((not (constant-lvar-p k)) (note-unwinnage "The ~:R argument (in keyword position) is not a ~ constant." n)) (t - (let* ((name (continuation-value k)) + (let* ((name (lvar-value k)) (info (find name (fun-type-keywords type) :key #'key-info-name))) (cond ((not info) @@ -354,8 +354,8 @@ (args (combination-args call)) (nargs (length args)) (allowp (some (lambda (x) - (and (constant-continuation-p x) - (eq (continuation-value x) :allow-other-keys))) + (and (constant-lvar-p x) + (eq (lvar-value x) :allow-other-keys))) args))) (setf (approximate-fun-type-min-args type) @@ -369,10 +369,10 @@ (setf (approximate-fun-type-types type) (nconc types (mapcar (lambda (x) - (list (continuation-type x))) + (list (lvar-type x))) arg)))) (when (null arg) (return)) - (pushnew (continuation-type (car arg)) + (pushnew (lvar-type (car arg)) (car old) :test #'type=)) @@ -383,8 +383,8 @@ (setf (approximate-fun-type-keys type) (keys))) (let ((key (first arg)) (val (second arg))) - (when (constant-continuation-p key) - (let ((name (continuation-value key))) + (when (constant-lvar-p key) + (let ((name (lvar-value key))) (when (keywordp name) (let ((old (find-if (lambda (x) @@ -392,7 +392,7 @@ (= (approximate-key-info-position x) pos))) (keys))) - (val-type (continuation-type val))) + (val-type (lvar-type val))) (cond (old (pushnew val-type (approximate-key-info-types old) @@ -726,7 +726,7 @@ (let* ((type-returns (fun-type-returns type)) (return (lambda-return (main-entry functional))) (dtype (when return - (continuation-derived-type (return-result return))))) + (lvar-derived-type (return-result return))))) (cond ((and dtype (not (values-types-equal-or-intersect dtype type-returns))) @@ -740,23 +740,23 @@ (t (let ((policy (lexenv-policy (functional-lexenv functional)))) (when (policy policy (> type-check 0)) - (assert-continuation-type (return-result return) type-returns - policy))) + (assert-lvar-type (return-result return) type-returns + policy))) (loop for var in vars and type in types do - (cond ((basic-var-sets var) - (when (and unwinnage-fun - (not (csubtypep (leaf-type var) type))) - (funcall unwinnage-fun - "Assignment to argument: ~S~% ~ + (cond ((basic-var-sets var) + (when (and unwinnage-fun + (not (csubtypep (leaf-type var) type))) + (funcall unwinnage-fun + "Assignment to argument: ~S~% ~ prevents use of assertion from function ~ type ~A:~% ~S~%" - (leaf-debug-name var) - where - (type-specifier type)))) - (t - (setf (leaf-type var) type) - (dolist (ref (leaf-refs var)) - (derive-node-type ref (make-single-value-type type)))))) + (leaf-debug-name var) + where + (type-specifier type)))) + (t + (setf (leaf-type var) type) + (dolist (ref (leaf-refs var)) + (derive-node-type ref (make-single-value-type type)))))) t)))))) ;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION. @@ -774,10 +774,10 @@ (ir1-attributep (fun-info-attributes it) explicit-check))))))) -;;; Call FUN with (arg-continuation arg-type) +;;; Call FUN with (arg-lvar arg-type) (defun map-combination-args-and-types (fun call) (declare (type function fun) (type combination call)) - (binding* ((type (continuation-type (combination-fun call))) + (binding* ((type (lvar-type (combination-fun call))) (nil (fun-type-p type) :exit-if-null) (args (combination-args call))) (dolist (req (fun-type-required type)) @@ -798,7 +798,7 @@ (let ((name (key-info-name key))) (do ((arg args (cddr arg))) ((null arg)) - (when (eq (continuation-value (first arg)) name) + (when (eq (lvar-value (first arg)) name) (funcall fun (second arg) (key-info-type key)))))))) ;;; Assert that CALL is to a function of the specified TYPE. It is @@ -810,20 +810,20 @@ (let ((policy (lexenv-policy (node-lexenv call)))) (map-combination-args-and-types (lambda (arg type) - (assert-continuation-type arg type policy)) + (assert-lvar-type arg type policy)) call)) (values)) ;;;; FIXME: Move to some other file. (defun check-catch-tag-type (tag) - (declare (type continuation tag)) - (let ((ctype (continuation-type tag))) + (declare (type lvar tag)) + (let ((ctype (lvar-type tag))) (when (csubtypep ctype (specifier-type '(or number character))) (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~ tends to be unportable because THROW and CATCH ~ use EQ comparison)~@:>" - (continuation-source tag) - (type-specifier (continuation-type tag)))))) + (lvar-source tag) + (type-specifier (lvar-type tag)))))) (defun %compile-time-type-error (values atype dtype) (declare (ignore dtype)) @@ -840,8 +840,8 @@ (destructuring-bind (values atype dtype) (basic-combination-args node) (declare (ignore values)) - (let ((atype (continuation-value atype)) - (dtype (continuation-value dtype))) + (let ((atype (lvar-value atype)) + (dtype (lvar-value dtype))) (unless (eq atype nil) (compiler-warn "~@<Asserted type ~S conflicts with derived type ~S.~@:>" Index: debug-dump.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/debug-dump.lisp,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- debug-dump.lisp 5 Aug 2003 14:11:38 -0000 1.31 +++ debug-dump.lisp 15 Sep 2003 09:21:38 -0000 1.32 @@ -141,11 +141,10 @@ (when (eq (block-info block) 2block) (unless (eql (source-path-tlf-number (node-source-path - (continuation-next - (block-start block)))) + (block-start-node block))) res) (setq res nil))) - + (dolist (loc (ir2-block-locations 2block)) (unless (eql (source-path-tlf-number (node-source-path @@ -163,7 +162,7 @@ (write-var-integer (length locations) *byte-buffer*) (let ((2block (block-info block))) (write-var-integer (+ (length locations) 1) *byte-buffer*) - (dump-1-location (continuation-next (block-start block)) + (dump-1-location (block-start-node block) 2block :block-start tlf-num (ir2-block-%label 2block) (ir2-block-live-out 2block) Index: debug.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/debug.lisp,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- debug.lisp 10 Jul 2003 07:27:03 -0000 1.29 +++ debug.lisp 15 Sep 2003 09:21:38 -0000 1.30 @@ -63,7 +63,7 @@ ;;; walk. (declaim (ftype (function (node) (values)) check-node-reached)) (defun check-node-reached (node) - (unless (gethash (continuation-block (node-prev node)) *seen-blocks*) + (unless (gethash (ctran-block (node-prev node)) *seen-blocks*) (barf "~S was not reached." node)) (values)) @@ -460,7 +460,7 @@ ;;; Check that the DEST for CONT is the specified NODE. We also mark ;;; the block CONT is in as SEEN. -(declaim (ftype (function (continuation node) (values)) check-dest)) +#+nil(declaim (ftype (function (continuation node) (values)) check-dest)) (defun check-dest (cont node) (let ((kind (continuation-kind cont))) (ecase kind @@ -935,11 +935,11 @@ (ir2-block (ir2-block-block thing)) (vop (block-or-lose (vop-block thing))) (tn-ref (block-or-lose (tn-ref-vop thing))) - (continuation (continuation-block thing)) + (ctran (ctran-block thing)) (node (node-block thing)) (component (component-head thing)) #| (cloop (loop-head thing))|# - (integer (continuation-block (num-cont thing))) + (integer (ctran-block (num-cont thing))) (functional (lambda-block (main-entry thing))) (null (error "Bad thing: ~S." thing)) (symbol (block-or-lose (gethash thing *free-funs*))))) @@ -950,73 +950,86 @@ (format t " c~D" (cont-num cont)) (values)) +(defun print-ctran (cont) + (declare (type ctran cont)) + (format t "c~D " (cont-num cont)) + (values)) +(defun print-lvar (cont) + (declare (type lvar cont)) + (format t "v~D " (cont-num cont)) + (values)) + ;;; Print out the nodes in BLOCK in a format oriented toward ;;; representing what the code does. (defun print-nodes (block) (setq block (block-or-lose block)) (pprint-logical-block (nil nil) (format t "~:@_IR1 block ~D start c~D" - (block-number block) (cont-num (block-start block))) + (block-number block) (cont-num (block-start block))) (when (block-delete-p block) (format t " <deleted>")) - (let ((last (block-last block))) - (pprint-newline :mandatory) - (do ((cont (block-start block) (node-cont (continuation-next cont)))) - ((not cont)) - (let ((node (continuation-next cont))) - (format t "~3D: " (cont-num (node-cont node))) - (etypecase node - (ref (print-leaf (ref-leaf node))) - (basic-combination - (let ((kind (basic-combination-kind node))) - (format t "~(~A~A ~A~) c~D" - (if (node-tail-p node) "tail " "") - (if (fun-info-p kind) "known" kind) - (type-of node) - (cont-num (basic-combination-fun node))) - (dolist (arg (basic-combination-args node)) - (if arg - (print-continuation arg) - (format t " <none>"))))) - (cset - (write-string "set ") - (print-leaf (set-var node)) - (print-continuation (set-value node))) - (cif - (format t "if c~D" (cont-num (if-test node))) - (print-continuation (block-start (if-consequent node))) - (print-continuation (block-start (if-alternative node)))) - (bind - (write-string "bind ") - (print-leaf (bind-lambda node)) - (when (functional-kind (bind-lambda node)) - (format t " ~S ~S" :kind (functional-kind (bind-lambda node))))) - (creturn - (format t "return c~D " (cont-num (return-result node))) - (print-leaf (return-lambda node))) - (entry - (format t "entry ~S" (entry-exits node))) - (exit - (let ((value (exit-value node))) - (cond (value - (format t "exit c~D" (cont-num value))) - ((exit-entry node) - (format t "exit <no value>")) - (t - (format t "exit <degenerate>"))))) - (cast - (let ((value (cast-value node))) - (format t "cast c~D ~A[~S -> ~S]" (cont-num value) - (if (cast-%type-check node) #\+ #\-) - (cast-type-to-check node) - (cast-asserted-type node))))) - (pprint-newline :mandatory) - (when (eq node last) (return))))) + (pprint-newline :mandatory) + (do ((ctran (block-start block) (node-next (ctran-next ctran)))) + ((not ctran)) + (let ((node (ctran-next ctran))) + (format t "~:[ ~;~:*~3D:~] " + (when (and (valued-node-p node) (node-lvar node)) + (cont-num (node-lvar node)))) + (etypecase node + (ref (print-leaf (ref-leaf node))) + (basic-combination + (let ((kind (basic-combination-kind node))) + (format t "~(~A~A ~A~) " + (if (node-tail-p node) "tail " "") + (if (fun-info-p kind) "known" kind) + (type-of node)) + (print-lvar (basic-combination-fun node)) + (dolist (arg (basic-combination-args node)) + (if arg + (print-lvar arg) + (format t "<none> "))))) + (cset + (write-string "set ") + (print-leaf (set-var node)) + (write-char #\space) + (print-lvar (set-value node))) + (cif + (write-string "if ") + (print-lvar (if-test node)) + (print-ctran (block-start (if-consequent node))) + (print-ctran (block-start (if-alternative node)))) + (bind + (write-string "bind ") + (print-leaf (bind-lambda node)) + (when (functional-kind (bind-lambda node)) + (format t " ~S ~S" :kind (functional-kind (bind-lambda node))))) + (creturn + (write-string "return ") + (print-lvar (return-result node)) + (print-leaf (return-lambda node))) + (entry + (format t "entry ~S" (entry-exits node))) + (exit + (let ((value (exit-value node))) + (cond (value + (format t "exit ") + (print-lvar value)) + ((exit-entry node) + (format t "exit <no value>")) + (t + (format t "exit <degenerate>"))))) + (cast + (let ((value (cast-value node))) + (format t "cast v~D ~A[~S -> ~S]" (cont-num value) + (if (cast-%type-check node) #\+ #\-) + (cast-type-to-check node) + (cast-asserted-type node))))) + (pprint-newline :mandatory))) - (let ((succ (block-succ block))) - (format t "successors~{ c~D~}~%" - (mapcar (lambda (x) (cont-num (block-start x))) succ)))) + (let ((succ (block-succ block))) + (format t "successors~{ c~D~}~%" + (mapcar (lambda (x) (cont-num (block-start x))) succ)))) (values)) ;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T) Index: dfo.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/dfo.lisp,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- dfo.lisp 3 Jun 2003 12:29:18 -0000 1.15 +++ dfo.lisp 15 Sep 2003 09:21:38 -0000 1.16 @@ -445,7 +445,7 @@ ;; in the old LAMBDA into the new one (with LETs implicitly moved ;; by changing their home.) (do-blocks (block component) - (do-nodes (node cont block) + (do-nodes (node nil block) (let ((lexenv (node-lexenv node))) (when (eq (lexenv-lambda lexenv) lambda) (setf (lexenv-lambda lexenv) result-lambda)))) @@ -506,14 +506,9 @@ ;; Make sure the result's return node starts a block so that we ;; can splice code in before it. (let ((prev (node-prev - (continuation-use - (return-result result-return))))) - (when (continuation-use prev) - (node-ends-block (continuation-use prev))) - (do-uses (use prev) - (let ((new (make-continuation))) - (delete-continuation-use use) - (add-continuation-use use new)))) + (lvar-uses (return-result result-return))))) + (when (ctran-use prev) + (node-ends-block (ctran-use prev)))) (dolist (lambda (rest lambdas)) (merge-1-toplevel-lambda result-lambda lambda))) Index: float-tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/float-tran.lisp,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- float-tran.lisp 1 Sep 2003 14:44:44 -0000 1.27 +++ float-tran.lisp 15 Sep 2003 09:21:38 -0000 1.28 @@ -56,10 +56,10 @@ ;; to let me scan for places that I made this mistake and didn't ;; catch myself. "use inline (UNSIGNED-BYTE 32) operations" - (let ((num-high (numeric-type-high (continuation-type num)))) + (let ((num-high (numeric-type-high (lvar-type num)))) (when (null num-high) (give-up-ir1-transform)) - (cond ((constant-continuation-p num) + (cond ((constant-lvar-p num) ;; Check the worst case sum absolute error for the random number ;; expectations. (let ((rem (rem (expt 2 32) num-high))) @@ -157,14 +157,14 @@ (deftransform scale-float ((f ex) (single-float *) *) (if (and #!+x86 t #!-x86 nil - (csubtypep (continuation-type ex) + (csubtypep (lvar-type ex) (specifier-type '(signed-byte 32)))) '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float) '(scale-single-float f ex))) (deftransform scale-float ((f ex) (double-float *) *) (if (and #!+x86 t #!-x86 nil - (csubtypep (continuation-type ex) + (csubtypep (lvar-type ex) (specifier-type '(signed-byte 32)))) '(%scalbn f ex) '(scale-double-float f ex))) @@ -274,10 +274,10 @@ ;;; rational arithmetic, or different float types, and fix it up. If ;;; we don't, he won't even get so much as an efficiency note. (deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node) - `(,(continuation-fun-name (basic-combinatio... [truncated message content] |