(in-package :sb-cltl2)
-(def-ir1-translator compiler-let ((bindings &rest forms) start cont)
+(def-ir1-translator compiler-let ((bindings &rest forms) start next result)
(loop for binding in bindings
if (atom binding)
collect binding into vars
and collect (first binding) into vars
and collect (eval (second binding)) into values
finally (return (progv vars values
- (sb-c::ir1-convert-progn-body start cont forms)))))
+ (sb-c::ir1-convert-progn-body start next result forms)))))
(defun walk-compiler-let (form context env)
(declare (ignore context))
(defoptimizer (%rotate-byte derive-type) ((count size posn num))
;; FIXME: this looks fairly unwieldy. I'm sure it can be made
;; simpler, and also be made to deal with negative integers too.
- (let ((size (sb-c::continuation-type size)))
+ (let ((size (sb-c::lvar-type size)))
(if (numeric-type-p size)
(let ((size-high (numeric-type-high size))
- (num-type (sb-c::continuation-type num)))
+ (num-type (sb-c::lvar-type num)))
(if (and size-high
num-type
(<= size-high sb-vm:n-word-bits)
;;; easily do this optimization in the cross-compiler, and SBCL itself
;;; doesn't seem to need this optimization, so we don't try.
(deftransform sxhash ((x) (simple-string))
- (if #+sb-xc-host nil #-sb-xc-host (constant-continuation-p x)
- (sxhash (continuation-value x))
+ (if #+sb-xc-host nil #-sb-xc-host (constant-lvar-p x)
+ (sxhash (lvar-value x))
'(%sxhash-simple-string x)))
(deftransform sxhash ((x) (symbol))
- (if #+sb-xc-host nil #-sb-xc-host (constant-continuation-p x)
- (sxhash (continuation-value x))
+ (if #+sb-xc-host nil #-sb-xc-host (constant-lvar-p x)
+ (sxhash (lvar-value x))
'(%sxhash-simple-string (symbol-name x))))
;;;; 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
(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*))
;;;; 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)))
(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*))
;;;; 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))))
(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*))
;;;; 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
(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)
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))
`(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)
(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
;;;; %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))
;;;; 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)
(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)
(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)))))
(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)))
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))
`(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)
(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)
(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
((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)
#!+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
(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))))
\f
;;;; 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
;;; 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),
*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*)))
;;; 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)))))
\f
;;;; 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))
;;; 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
(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
(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)))
(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
(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
;;; 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"
(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)))
;;; 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)))
;;; (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)))
;;; 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)))
;;; 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))))
;;; 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)))
;;; 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)))
(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)))))
\f
;;;; WITH-ARRAY-DATA
\f
;;; 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
;;; 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)
;;; 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)
(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
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
;;; 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)
;; 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
;;; 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
;;; 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))
;;; 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)
(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)))))))
(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)
(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))))
(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))
(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)
(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))
(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
;; 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
(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)))
(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)))
(*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"
(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)
(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)
(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)
(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=))
(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)
(= (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)
(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)))
(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.
(ir1-attributep (fun-info-attributes it)
explicit-check)))))))
\f
-;;; 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))
(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
(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))
\f
;;;; 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))
(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.~@:>"
(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
(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)
;;; 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))
;;; 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
(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*)))))
(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)))))
-
- (let ((succ (block-succ block)))
- (format t "successors~{ c~D~}~%"
- (mapcar (lambda (x) (cont-num (block-start x))) succ))))
+ (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))))
(values))
;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T)
;; 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))))
;; 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)))
;; 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)))
(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)))
;;; 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-combination-fun node))
+ `(,(lvar-fun-name (basic-combination-fun node))
(float x y) y))
(deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
- `(,(continuation-fun-name (basic-combination-fun node))
+ `(,(lvar-fun-name (basic-combination-fun node))
x (float y x)))
(dolist (x '(+ * / -))
(macrolet ((frob (op)
`(deftransform ,op ((x y) (float rational) *)
"open-code FLOAT to RATIONAL comparison"
- (unless (constant-continuation-p y)
+ (unless (constant-lvar-p y)
(give-up-ir1-transform
"The RATIONAL value isn't known at compile time."))
- (let ((val (continuation-value y)))
+ (let ((val (lvar-value y)))
(unless (eql (rational (float val)) val)
(give-up-ir1-transform
"~S doesn't have a precise float representation."
(setf (fun-info-derive-type (fun-info-or-lose name))
(lambda (call)
(declare (type combination call))
- (when (csubtypep (continuation-type
+ (when (csubtypep (lvar-type
(first (combination-args call)))
type)
(specifier-type 'float)))))))
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (log derive-type) ((x &optional y))
- (when (and (csubtypep (continuation-type x)
+ (when (and (csubtypep (lvar-type x)
(specifier-type '(real 0.0)))
(or (null y)
- (csubtypep (continuation-type y)
+ (csubtypep (lvar-type y)
(specifier-type '(real 0.0)))))
(specifier-type 'float)))
\f
(declare (ignorable prim-quick))
`(progn
(deftransform ,name ((x) (single-float) *)
- #!+x86 (cond ((csubtypep (continuation-type x)
+ #!+x86 (cond ((csubtypep (lvar-type x)
(specifier-type '(single-float
(#.(- (expt 2f0 64)))
(#.(expt 2f0 64)))))
(compiler-notify
"unable to avoid inline argument range check~@
because the argument range (~S) was not within 2^64"
- (type-specifier (continuation-type x)))
+ (type-specifier (lvar-type x)))
`(coerce (,',prim (coerce x 'double-float)) 'single-float)))
#!-x86 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
(deftransform ,name ((x) (double-float) *)
- #!+x86 (cond ((csubtypep (continuation-type x)
+ #!+x86 (cond ((csubtypep (lvar-type x)
(specifier-type '(double-float
(#.(- (expt 2d0 64)))
(#.(expt 2d0 64)))))
(compiler-notify
"unable to avoid inline argument range check~@
because the argument range (~S) was not within 2^64"
- (type-specifier (continuation-type x)))
+ (type-specifier (lvar-type x)))
`(,',prim x)))
#!-x86 `(,',prim x)))))
(def sin %sin %sin-quick)
;;; FIXME: ANSI allows any subtype of REAL for the components of COMPLEX.
;;; So what if the input type is (COMPLEX (SINGLE-FLOAT 0 1))?
(defoptimizer (conjugate derive-type) ((num))
- (continuation-type num))
+ (lvar-type num))
(defoptimizer (cis derive-type) ((num))
(one-arg-derive-type num
(in-package "SB!C")
(defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
- (let* ((cont (node-cont node))
- (locs (continuation-result-tns cont
+ (let* ((lvar (node-lvar node))
+ (locs (lvar-result-tns lvar
(list *backend-t-primitive-type*)))
(res (first locs)))
- (vop slot node block (continuation-tn node block object)
+ (vop slot node block (lvar-tn node block object)
name offset lowtag res)
- (move-continuation-result node block locs cont)))
+ (move-lvar-result node block locs lvar)))
(defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
- (let ((value-tn (continuation-tn node block value)))
- (vop set-slot node block (continuation-tn node block object) value-tn
+ (let ((value-tn (lvar-tn node block value)))
+ (vop set-slot node block (lvar-tn node block object) value-tn
name offset lowtag)
- (move-continuation-result node block (list value-tn) (node-cont node))))
+ (move-lvar-result node block (list value-tn) (node-lvar node))))
;;; FIXME: Isn't there a name for this which looks less like a typo?
;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
(defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
- (let ((value-tn (continuation-tn node block value)))
- (vop set-slot node block (continuation-tn node block object) value-tn
+ (let ((value-tn (lvar-tn node block value)))
+ (vop set-slot node block (lvar-tn node block object) value-tn
name offset lowtag)
- (move-continuation-result node block (list value-tn) (node-cont node))))
+ (move-lvar-result node block (list value-tn) (node-lvar node))))
(defun do-inits (node block name result lowtag inits args)
(let ((unbound-marker-tn nil))
(ecase kind
(:arg
(aver args)
- (continuation-tn node block (pop args)))
+ (lvar-tn node block (pop args)))
(:unbound
(or unbound-marker-tn
(setf unbound-marker-tn
(defoptimizer ir2-convert-fixed-allocation
((&rest args) node block name words type lowtag inits)
- (let* ((cont (node-cont node))
- (locs (continuation-result-tns cont
+ (let* ((lvar (node-lvar node))
+ (locs (lvar-result-tns lvar
(list *backend-t-primitive-type*)))
(result (first locs)))
(do-fixed-alloc node block name words type lowtag result)
(do-inits node block name result lowtag inits args)
- (move-continuation-result node block locs cont)))
+ (move-lvar-result node block locs lvar)))
(defoptimizer ir2-convert-variable-allocation
((extra &rest args) node block name words type lowtag inits)
- (let* ((cont (node-cont node))
- (locs (continuation-result-tns cont
+ (let* ((lvar (node-lvar node))
+ (locs (lvar-result-tns lvar
(list *backend-t-primitive-type*)))
(result (first locs)))
- (if (constant-continuation-p extra)
- (let ((words (+ (continuation-value extra) words)))
+ (if (constant-lvar-p extra)
+ (let ((words (+ (lvar-value extra) words)))
(do-fixed-alloc node block name words type lowtag result))
- (vop var-alloc node block (continuation-tn node block extra) name words
+ (vop var-alloc node block (lvar-tn node block extra) name words
type lowtag result))
(do-inits node block name result lowtag inits args)
- (move-continuation-result node block locs cont)))
+ (move-lvar-result node block locs lvar)))
;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
;;; cut it for symbols, where under certain compilation options
(lambda (node block)
(let ((args (basic-combination-args node)))
(destructuring-bind (symbol value) args
- (let ((value-tn (continuation-tn node block value)))
+ (let ((value-tn (lvar-tn node block value)))
(vop set node block
- (continuation-tn node block symbol) value-tn)
- (move-continuation-result
- node block (list value-tn) (node-cont node))))))))
+ (lvar-tn node block symbol) value-tn)
+ (move-lvar-result
+ node block (list value-tn) (node-lvar node))))))))
;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
(deftransform hairy-data-vector-ref ((string index) (simple-string t))
- (let ((ctype (continuation-type string)))
+ (let ((ctype (lvar-type string)))
(if (array-type-p ctype)
;; the other transform will kick in, so that's OK
(give-up-ir1-transform)
(deftransform data-vector-ref ((array index)
(simple-array t))
- (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)))
(deftransform hairy-data-vector-set ((string index new-value)
(simple-string t t))
- (let ((ctype (continuation-type string)))
+ (let ((ctype (lvar-type string)))
(if (array-type-p ctype)
;; the other transform will kick in, so that's OK
(give-up-ir1-transform)
(deftransform data-vector-set ((array index new-value)
(simple-array t t))
- (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)))
new-value)))))
(defoptimizer (%data-vector-and-index derive-type) ((array index))
- (let ((atype (continuation-type array)))
+ (let ((atype (lvar-type array)))
(when (array-type-p atype)
(values-specifier-type
`(values (simple-array ,(type-specifier
(deftransform fill ((sequence item) (simple-bit-vector bit) *
:policy (>= speed space))
- (let ((value (if (constant-continuation-p item)
- (if (= (continuation-value item) 0)
+ (let ((value (if (constant-lvar-p item)
+ (if (= (lvar-value item) 0)
0
#.(1- (ash 1 32)))
`(if (= item 0) 0 #.(1- (ash 1 32))))))
(deftransform fill ((sequence item) (simple-base-string base-char) *
:policy (>= speed space))
- (let ((value (if (constant-continuation-p item)
- (let* ((char (continuation-value item))
+ (let ((value (if (constant-lvar-p item)
+ (let* ((char (lvar-value item))
(code (sb!xc:char-code char)))
(logior code (ash code 8) (ash code 16) (ash code 24)))
`(let ((code (sb!xc:char-code item)))
:node node
:result result)
"32-bit implementation"
- (let ((dest (continuation-dest result)))
+ (let ((dest (lvar-dest result)))
(unless (and (combination-p dest)
- (eq (continuation-fun-name (combination-fun dest))
+ (eq (lvar-fun-name (combination-fun dest))
'logand))
(give-up-ir1-transform))
(unless (some (lambda (arg)
- (csubtypep (continuation-type arg)
+ (csubtypep (lvar-type arg)
(specifier-type '(unsigned-byte 32))))
(combination-args dest))
(give-up-ir1-transform))
(block punt
(dolist (fun funs t)
(dolist (ref (leaf-refs fun))
- (let* ((cont (node-cont ref))
- (dest (continuation-dest cont)))
- (when (and dest
+ (let* ((lvar (node-lvar ref))
+ (dest (and lvar (lvar-dest lvar))))
+ (when (and (basic-combination-p dest)
(not (node-tail-p dest))
- (basic-combination-p dest)
- (eq (basic-combination-fun dest) cont)
+ (eq (basic-combination-fun dest) lvar)
(eq (basic-combination-kind dest) :local))
(return-from punt nil)))))))))
\f
;;;; special forms for control
-(def-ir1-translator progn ((&rest forms) start cont)
+(def-ir1-translator progn ((&rest forms) start next result)
#!+sb-doc
"Progn Form*
Evaluates each Form in order, returning the values of the last form. With no
forms, returns NIL."
- (ir1-convert-progn-body start cont forms))
+ (ir1-convert-progn-body start next result forms))
-(def-ir1-translator if ((test then &optional else) start cont)
+(def-ir1-translator if ((test then &optional else) start next result)
#!+sb-doc
"If Predicate Then [Else]
If Predicate evaluates to non-null, evaluate Then and returns its values,
otherwise evaluate Else and return its values. Else defaults to NIL."
- (let* ((pred (make-continuation))
- (then-cont (make-continuation))
- (then-block (continuation-starts-block then-cont))
- (else-cont (make-continuation))
- (else-block (continuation-starts-block else-cont))
- (dummy-cont (make-continuation))
- (node (make-if :test pred
+ (let* ((pred-ctran (make-ctran))
+ (pred-lvar (make-lvar))
+ (then-ctran (make-ctran))
+ (then-block (ctran-starts-block then-ctran))
+ (else-ctran (make-ctran))
+ (else-block (ctran-starts-block else-ctran))
+ (node (make-if :test pred-lvar
:consequent then-block
:alternative else-block)))
;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
;; order of the following two forms is important
- (setf (continuation-dest pred) node)
- (ir1-convert start pred test)
- (link-node-to-previous-continuation node pred)
- (use-continuation node dummy-cont)
+ (setf (lvar-dest pred-lvar) node)
+ (ir1-convert start pred-ctran pred-lvar test)
+ (link-node-to-previous-ctran node pred-ctran)
- (let ((start-block (continuation-block pred)))
+ (let ((start-block (ctran-block pred-ctran)))
(setf (block-last start-block) node)
- (continuation-starts-block cont)
+ (ctran-starts-block next)
(link-blocks start-block then-block)
(link-blocks start-block else-block))
- (ir1-convert then-cont cont then)
- (ir1-convert else-cont cont else)))
+ (ir1-convert then-ctran next result then)
+ (ir1-convert else-ctran next result else)))
\f
;;;; BLOCK and TAGBODY
;;; body in the modified environment. We make CONT start a block now,
;;; since if it was done later, the block would be in the wrong
;;; environment.
-(def-ir1-translator block ((name &rest forms) start cont)
+(def-ir1-translator block ((name &rest forms) start next result)
#!+sb-doc
"Block Name Form*
Evaluate the Forms as a PROGN. Within the lexical scope of the body,
result of Value-Form."
(unless (symbolp name)
(compiler-error "The block name ~S is not a symbol." name))
- (continuation-starts-block cont)
- (let* ((dummy (make-continuation))
+ (ctran-starts-block next)
+ (let* ((dummy (make-ctran))
(entry (make-entry))
(cleanup (make-cleanup :kind :block
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (link-node-to-previous-continuation entry start)
- (use-continuation entry dummy)
+ (link-node-to-previous-ctran entry start)
+ (use-ctran entry dummy)
- (let* ((env-entry (list entry cont))
+ (let* ((env-entry (list entry next result))
(*lexenv* (make-lexenv :blocks (list (cons name env-entry))
:cleanup cleanup)))
- (push env-entry (continuation-lexenv-uses cont))
- (ir1-convert-progn-body dummy cont forms))))
+ (ir1-convert-progn-body dummy next result forms))))
-(def-ir1-translator return-from ((name &optional value) start cont)
+(def-ir1-translator return-from ((name &optional value) start next result)
#!+sb-doc
"Return-From Block-Name Value-Form
Evaluate the Value-Form, returning its values from the lexically enclosing
;; BLOCK-HOME-LAMBDA-OR-NULL) more obscure, and it might be better
;; to get rid of it, perhaps using a special placeholder value
;; to indicate the orphanedness of the code.
- (continuation-starts-block cont)
+ (declare (ignore result))
+ (ctran-starts-block next)
(let* ((found (or (lexenv-find name blocks)
(compiler-error "return for unknown block: ~S" name)))
- (value-cont (make-continuation))
+ (value-ctran (make-ctran))
+ (value-lvar (make-lvar))
(entry (first found))
(exit (make-exit :entry entry
- :value value-cont)))
+ :value value-lvar)))
(push exit (entry-exits entry))
- (setf (continuation-dest value-cont) exit)
- (ir1-convert start value-cont value)
- (link-node-to-previous-continuation exit value-cont)
- (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (setf (lvar-dest value-lvar) exit)
+ (ir1-convert start value-ctran value-lvar value)
+ (link-node-to-previous-ctran exit value-ctran)
+ (let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
- (use-continuation exit (second found))))
+ (use-continuation exit (second found) (third found))))
;;; Return a list of the segments of a TAGBODY. Each segment looks
;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
;;; each tag, building up the tag list for LEXENV-TAGS as we go.
;;; Finally, convert each segment with the precomputed Start and Cont
;;; values.
-(def-ir1-translator tagbody ((&rest statements) start cont)
+(def-ir1-translator tagbody ((&rest statements) start next result)
#!+sb-doc
"Tagbody {Tag | Statement}*
Define tags for used with GO. The Statements are evaluated in order
to the next statement following that tag. A Tag must an integer or a
symbol. A statement must be a list. Other objects are illegal within the
body."
- (continuation-starts-block cont)
- (let* ((dummy (make-continuation))
+ (ctran-starts-block next)
+ (let* ((dummy (make-ctran))
(entry (make-entry))
(segments (parse-tagbody statements))
(cleanup (make-cleanup :kind :tagbody
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
- (link-node-to-previous-continuation entry start)
- (use-continuation entry dummy)
+ (link-node-to-previous-ctran entry start)
+ (use-ctran entry dummy)
(collect ((tags)
(starts)
- (conts))
+ (ctrans))
(starts dummy)
(dolist (segment (rest segments))
- (let* ((tag-cont (make-continuation))
- (tag (list (car segment) entry tag-cont)))
- (conts tag-cont)
- (starts tag-cont)
- (continuation-starts-block tag-cont)
- (tags tag)
- (push (cdr tag) (continuation-lexenv-uses tag-cont))))
- (conts cont)
+ (let* ((tag-ctran (make-ctran))
+ (tag (list (car segment) entry tag-ctran)))
+ (ctrans tag-ctran)
+ (starts tag-ctran)
+ (ctran-starts-block tag-ctran)
+ (tags tag)))
+ (ctrans next)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
- (mapc (lambda (segment start cont)
- (ir1-convert-progn-body start cont (rest segment)))
- segments (starts) (conts))))))
+ (mapc (lambda (segment start end)
+ (ir1-convert-progn-body start end
+ (when (eq end next) result)
+ (rest segment)))
+ segments (starts) (ctrans))))))
;;; Emit an EXIT node without any value.
-(def-ir1-translator go ((tag) start cont)
+(def-ir1-translator go ((tag) start next result)
#!+sb-doc
"Go Tag
Transfer control to the named Tag in the lexically enclosing TAGBODY. This
is constrained to be used only within the dynamic extent of the TAGBODY."
- (continuation-starts-block cont)
+ (ctran-starts-block next)
(let* ((found (or (lexenv-find tag tags :test #'eql)
(compiler-error "attempt to GO to nonexistent tag: ~S"
tag)))
(entry (first found))
(exit (make-exit :entry entry)))
(push exit (entry-exits entry))
- (link-node-to-previous-continuation exit start)
- (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (link-node-to-previous-ctran exit start)
+ (let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
- (use-continuation exit (second found))))
+ (use-ctran exit (second found))))
\f
;;;; translators for compiler-magic special forms
;;; eval-when specifying the :EXECUTE situation is treated as an
;;; implicit PROGN including the forms in the body of the EVAL-WHEN
;;; form; otherwise, the forms in the body are ignored.
-(def-ir1-translator eval-when ((situations &rest forms) start cont)
+(def-ir1-translator eval-when ((situations &rest forms) start next result)
#!+sb-doc
"EVAL-WHEN (Situation*) Form*
Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
(multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
(declare (ignore ct lt))
- (ir1-convert-progn-body start cont (and e forms)))
+ (ir1-convert-progn-body start next result (and e forms)))
(values))
;;; common logic for MACROLET and SYMBOL-MACROLET
definitions
fun))
-(def-ir1-translator macrolet ((definitions &rest body) start cont)
+(def-ir1-translator macrolet ((definitions &rest body) start next result)
#!+sb-doc
"MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
Evaluate the Body-Forms in an environment with the specified local macros
definitions
(lambda (&key funs)
(declare (ignore funs))
- (ir1-translate-locally body start cont))
+ (ir1-translate-locally body start next result))
:compile))
(defun symbol-macrolet-definitionize-fun (context)
definitions
fun))
-(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
+(def-ir1-translator symbol-macrolet
+ ((macrobindings &body body) start next result)
#!+sb-doc
"SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
Define the Names as symbol macros with the given Expansions. Within the
(funcall-in-symbol-macrolet-lexenv
macrobindings
(lambda (&key vars)
- (ir1-translate-locally body start cont :vars vars))
+ (ir1-translate-locally body start next result :vars vars))
:compile))
\f
;;;; %PRIMITIVE
;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
;;; VOP or %VOP.. -- WHN 2001-06-11
;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
-(def-ir1-translator %primitive ((name &rest args) start cont)
+(def-ir1-translator %primitive ((name &rest args) start next result)
(declare (type symbol name))
(let* ((template (or (gethash name *backend-template-names*)
(bug "undefined primitive ~A" name)))
(when (template-more-results-type template)
(bug "%PRIMITIVE was used with an unknown values template."))
- (ir1-convert start
- cont
+ (ir1-convert start next result
`(%%primitive ',template
',(eval-info-args
(subseq args required min))
\f
;;;; QUOTE
-(def-ir1-translator quote ((thing) start cont)
+(def-ir1-translator quote ((thing) start next result)
#!+sb-doc
"QUOTE Value
Return Value without evaluating it."
- (reference-constant start cont thing))
+ (reference-constant start next result thing))
\f
;;;; FUNCTION and NAMED-LAMBDA
(defun fun-name-leaf (thing)
(find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
-(def-ir1-translator function ((thing) start cont)
+(def-ir1-translator function ((thing) start next result)
#!+sb-doc
"FUNCTION Name
Return the lexically apparent definition of the function Name. Name may also
be a lambda expression."
- (reference-leaf start cont (fun-name-leaf thing)))
+ (reference-leaf start next result (fun-name-leaf thing)))
\f
;;;; FUNCALL
(deftransform funcall ((function &rest args) * *)
(let ((arg-names (make-gensym-list (length args))))
`(lambda (function ,@arg-names)
- (%funcall ,(if (csubtypep (continuation-type function)
+ (%funcall ,(if (csubtypep (lvar-type function)
(specifier-type 'function))
'function
'(%coerce-callable-to-fun function))
,@arg-names))))
-(def-ir1-translator %funcall ((function &rest args) start cont)
+(def-ir1-translator %funcall ((function &rest args) start next result)
(if (and (consp function) (eq (car function) 'function))
- (ir1-convert start cont `(,(fun-name-leaf (second function)) ,@args))
- (let ((fun-cont (make-continuation)))
- (ir1-convert start fun-cont `(the function ,function))
- (ir1-convert-combination-args fun-cont cont args))))
+ (ir1-convert start next result
+ `(,(fun-name-leaf (second function)) ,@args))
+ (let ((fun-ctran (make-ctran))
+ (fun-lvar (make-lvar)))
+ (ir1-convert start fun-ctran fun-lvar `(the function ,function))
+ (ir1-convert-combination-args fun-ctran fun-lvar next result args))))
;;; This source transform exists to reduce the amount of work for the
;;; compiler. If the called function is a FUNCTION form, then convert
(values (vars) (vals))))
-(def-ir1-translator let ((bindings &body body) start cont)
+(def-ir1-translator let ((bindings &body body) start next result)
#!+sb-doc
"LET ({(Var [Value]) | Var}*) Declaration* Form*
During evaluation of the Forms, bind the Vars to the result of evaluating the
Value forms. The variables are bound in parallel after all of the Values are
evaluated."
(if (null bindings)
- (ir1-translate-locally body start cont)
+ (ir1-translate-locally body start next result)
(multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
+ (parse-body body :doc-string-allowed nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let)
- (let* ((fun-cont (make-continuation))
- (cont (processing-decls (decls vars nil cont)
- (let ((fun (ir1-convert-lambda-body
- forms vars
- :debug-name (debug-namify "LET ~S"
- bindings))))
- (reference-leaf start fun-cont fun))
- cont)))
- (ir1-convert-combination-args fun-cont cont values))))))
+ (binding* ((fun-ctran (make-ctran))
+ (fun-lvar (make-lvar))
+ ((next result)
+ (processing-decls (decls vars nil next result)
+ (let ((fun (ir1-convert-lambda-body
+ forms vars
+ :debug-name (debug-namify "LET ~S"
+ bindings))))
+ (reference-leaf start fun-ctran fun-lvar fun))
+ (values next result))))
+ (ir1-convert-combination-args fun-ctran fun-lvar next result values))))))
(def-ir1-translator let* ((bindings &body body)
- start cont)
+ start next result)
#!+sb-doc
"LET* ({(Var [Value]) | Var}*) Declaration* Form*
Similar to LET, but the variables are bound sequentially, allowing each Value
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
- (processing-decls (decls vars nil cont)
- (ir1-convert-aux-bindings start cont forms vars values)))))
+ (processing-decls (decls vars nil start next)
+ (ir1-convert-aux-bindings start next result forms vars values)))))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
;;; and SYMBOL-MACROLET
;;; but we don't need to worry about that within an IR1 translator,
;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO
;;; forms before we hit the IR1 transform level.
-(defun ir1-translate-locally (body start cont &key vars funs)
- (declare (type list body) (type continuation start cont))
+(defun ir1-translate-locally (body start next result &key vars funs)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (type list body))
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
- (processing-decls (decls vars funs cont)
- (ir1-convert-progn-body start cont forms))))
+ (processing-decls (decls vars funs next result)
+ (ir1-convert-progn-body start next result forms))))
-(def-ir1-translator locally ((&body body) start cont)
+(def-ir1-translator locally ((&body body) start next result)
#!+sb-doc
"LOCALLY Declaration* Form*
Sequentially evaluate the Forms in a lexical environment where the
the Declarations have effect. If LOCALLY is a top level form, then
the Forms are also processed as top level forms."
- (ir1-translate-locally body start cont))
+ (ir1-translate-locally body start next result))
\f
;;;; FLET and LABELS
(values (names) (defs))))
(def-ir1-translator flet ((definitions &body body)
- start cont)
+ start next result)
#!+sb-doc
"FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
Evaluate the Body-Forms with some local function definitions. The bindings
"FLET ~S" n)
:allow-debug-catch-tag t))
names defs)))
- (processing-decls (decls nil fvars cont)
+ (processing-decls (decls nil fvars next result)
(let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
- (ir1-convert-progn-body start cont forms)))))))
+ (ir1-convert-progn-body start next result forms)))))))
-(def-ir1-translator labels ((definitions &body body) start cont)
+(def-ir1-translator labels ((definitions &body body) start next result)
#!+sb-doc
"LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
Evaluate the Body-Forms with some local function definitions. The bindings
(setf (cdr placeholder-cons) real-fun))
;; Voila.
- (processing-decls (decls nil real-funs cont)
+ (processing-decls (decls nil real-funs next result)
(let ((*lexenv* (make-lexenv
;; Use a proper FENV here (not the
;; placeholder used earlier) so that if the
;; lexical environment is used for inline
;; expansion we'll get the right functions.
:funs (pairlis names real-funs))))
- (ir1-convert-progn-body start cont forms)))))))
+ (ir1-convert-progn-body start next result forms)))))))
\f
;;;; the THE special operator, and friends
;;; A logic shared among THE and TRULY-THE.
-(defun the-in-policy (type value policy start cont)
+(defun the-in-policy (type value policy start next result)
(let ((type (if (ctype-p type) type
(compiler-values-specifier-type type))))
(cond ((or (eq type *wild-type*)
(and (sb!xc:constantp value)
(ctypep (constant-form-value value)
(single-value-type type))))
- (ir1-convert start cont value))
- (t (let ((value-cont (make-continuation)))
- (ir1-convert start value-cont value)
- (let ((cast (make-cast value-cont type policy)))
- (link-node-to-previous-continuation cast value-cont)
- (setf (continuation-dest value-cont) cast)
- (use-continuation cast cont)))))))
+ (ir1-convert start next result value))
+ (t (let ((value-ctran (make-ctran))
+ (value-lvar (make-lvar)))
+ (ir1-convert start value-ctran value-lvar value)
+ (let ((cast (make-cast value-lvar type policy)))
+ (link-node-to-previous-ctran cast value-ctran)
+ (setf (lvar-dest value-lvar) cast)
+ (use-continuation cast next result)))))))
;;; Assert that FORM evaluates to the specified type (which may be a
;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
-(def-ir1-translator the ((type value) start cont)
- (the-in-policy type value (lexenv-policy *lexenv*) start cont))
+(def-ir1-translator the ((type value) start next result)
+ (the-in-policy type value (lexenv-policy *lexenv*) start next result))
;;; This is like the THE special form, except that it believes
;;; whatever you tell it. It will never generate a type check, but
;;; will cause a warning if the compiler can prove the assertion is
;;; wrong.
-(def-ir1-translator truly-the ((type value) start cont)
+(def-ir1-translator truly-the ((type value) start next result)
#!+sb-doc
""
(declare (inline member))
#-nil
(let ((type (coerce-to-values (compiler-values-specifier-type type)))
- (old (find-uses cont)))
- (ir1-convert start cont value)
- (do-uses (use cont)
- (unless (member use old :test #'eq)
+ (old (find-uses result)))
+ (ir1-convert start next result value)
+ (do-uses (use result)
+ (unless (memq use old)
(derive-node-type use type))))
#+nil
(the-in-policy type value '((type-check . 0)) start cont))
;;; If there is a definition in LEXENV-VARS, just set that, otherwise
;;; look at the global information. If the name is for a constant,
;;; then error out.
-(def-ir1-translator setq ((&whole source &rest things) start cont)
+(def-ir1-translator setq ((&whole source &rest things) start next result)
(let ((len (length things)))
(when (oddp len)
(compiler-error "odd number of args to SETQ: ~S" source))
(when (constant-p leaf)
(compiler-error "~S is a constant and thus can't be set." name))
(when (lambda-var-p leaf)
- (let ((home-lambda (continuation-home-lambda-or-null start)))
+ (let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
(pushnew leaf (lambda-calls-or-closes home-lambda))))
(when (lambda-var-ignorep leaf)
(compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
- (setq-var start cont leaf (second things)))
+ (setq-var start next result leaf (second things)))
(cons
(aver (eq (car leaf) 'MACRO))
;; FIXME: [Free] type declaration. -- APD, 2002-01-26
- (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
+ (ir1-convert start next result
+ `(setf ,(cdr leaf) ,(second things))))
(heap-alien-info
- (ir1-convert start cont
+ (ir1-convert start next result
`(%set-heap-alien ',leaf ,(second things))))))
(collect ((sets))
(do ((thing things (cddr thing)))
((endp thing)
- (ir1-convert-progn-body start cont (sets)))
+ (ir1-convert-progn-body start next result (sets)))
(sets `(setq ,(first thing) ,(second thing))))))))
;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
;;; This should only need to be called in SETQ.
-(defun setq-var (start cont var value)
- (declare (type continuation start cont) (type basic-var var))
- (let ((dest (make-continuation))
+(defun setq-var (start next result var value)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (type basic-var var))
+ (let ((dest-ctran (make-ctran))
+ (dest-lvar (make-lvar))
(type (or (lexenv-find var type-restrictions)
(leaf-type var))))
- (ir1-convert start dest `(the ,type ,value))
- (let ((res (make-set :var var :value dest)))
- (setf (continuation-dest dest) res)
+ (ir1-convert start dest-ctran dest-lvar `(the ,type ,value))
+ (let ((res (make-set :var var :value dest-lvar)))
+ (setf (lvar-dest dest-lvar) res)
(setf (leaf-ever-used var) t)
(push res (basic-var-sets var))
- (link-node-to-previous-continuation res dest)
- (use-continuation res cont))))
+ (link-node-to-previous-ctran res dest-ctran)
+ (use-continuation res next result))))
\f
;;;; CATCH, THROW and UNWIND-PROTECT
;;; We turn THROW into a MULTIPLE-VALUE-CALL of a magical function,
;;; since as as far as IR1 is concerned, it has no interesting
;;; properties other than receiving multiple-values.
-(def-ir1-translator throw ((tag result) start cont)
+(def-ir1-translator throw ((tag result) start next result-lvar)
#!+sb-doc
"Throw Tag Form
Do a non-local exit, return the values of Form from the CATCH whose tag
evaluates to the same thing as Tag."
- (ir1-convert start cont
+ (ir1-convert start next result-lvar
`(multiple-value-call #'%throw ,tag ,result)))
;;; This is a special special form used to instantiate a cleanup as
;;; and introduce the cleanup into the lexical environment. We
;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
;;; cleanup, since this inner cleanup is the interesting one.
-(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
- (let ((dummy (make-continuation))
- (dummy2 (make-continuation)))
- (ir1-convert start dummy mess-up)
- (let* ((mess-node (continuation-use dummy))
+(def-ir1-translator %within-cleanup
+ ((kind mess-up &body body) start next result)
+ (let ((dummy (make-ctran))
+ (dummy2 (make-ctran)))
+ (ir1-convert start dummy nil mess-up)
+ (let* ((mess-node (ctran-use dummy))
(cleanup (make-cleanup :kind kind
:mess-up mess-node))
(old-cup (lexenv-cleanup *lexenv*))
(*lexenv* (make-lexenv :cleanup cleanup)))
(setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
- (ir1-convert dummy dummy2 '(%cleanup-point))
- (ir1-convert-progn-body dummy2 cont body))))
+ (ir1-convert dummy dummy2 nil '(%cleanup-point))
+ (ir1-convert-progn-body dummy2 next result body))))
;;; This is a special special form that makes an "escape function"
;;; which returns unknown values from named block. We convert the
;;;
;;; Note that environment analysis replaces references to escape
;;; functions with references to the corresponding NLX-INFO structure.
-(def-ir1-translator %escape-fun ((tag) start cont)
+(def-ir1-translator %escape-fun ((tag) start next result)
(let ((fun (ir1-convert-lambda
`(lambda ()
(return-from ,tag (%unknown-values)))
:debug-name (debug-namify "escape function for ~S" tag))))
(setf (functional-kind fun) :escape)
- (reference-leaf start cont fun)))
+ (reference-leaf start next result fun)))
;;; Yet another special special form. This one looks up a local
;;; function and smashes it to a :CLEANUP function, as well as
;;; referencing it.
-(def-ir1-translator %cleanup-fun ((name) start cont)
+(def-ir1-translator %cleanup-fun ((name) start next result)
(let ((fun (lexenv-find name funs)))
(aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
- (reference-leaf start cont fun)))
+ (reference-leaf start next result fun)))
-(def-ir1-translator catch ((tag &body body) start cont)
+(def-ir1-translator catch ((tag &body body) start next result)
#!+sb-doc
"Catch Tag Form*
Evaluate TAG and instantiate it as a catcher while the body forms are
;; "escape function" that does a lexical exit, and instantiate the
;; cleanup using %WITHIN-CLEANUP.
(ir1-convert
- start cont
+ start next result
(with-unique-names (exit-block)
`(block ,exit-block
(%within-cleanup
(%catch (%escape-fun ,exit-block) ,tag)
,@body)))))
-(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
+(def-ir1-translator unwind-protect
+ ((protected &body cleanup) start next result)
#!+sb-doc
"Unwind-Protect Protected Cleanup*
Evaluate the form PROTECTED, returning its values. The CLEANUP forms are
;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
;; an XEP.
(ir1-convert
- start cont
+ start next result
(with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)
`(flet ((,cleanup-fun () ,@cleanup nil))
;; FIXME: If we ever get DYNAMIC-EXTENT working, then
\f
;;;; multiple-value stuff
-(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
+(def-ir1-translator multiple-value-call ((fun &rest args) start next result)
#!+sb-doc
"MULTIPLE-VALUE-CALL Function Values-Form*
Call FUNCTION, passing all the values of each VALUES-FORM as arguments,
values from the first VALUES-FORM making up the first argument, etc."
- (let* ((fun-cont (make-continuation))
+ (let* ((fun-ctran (make-ctran))
+ (fun-lvar (make-lvar))
(node (if args
;; If there are arguments, MULTIPLE-VALUE-CALL
;; turns into an MV-COMBINATION.
- (make-mv-combination fun-cont)
+ (make-mv-combination fun-lvar)
;; If there are no arguments, then we convert to a
;; normal combination, ensuring that a MV-COMBINATION
;; always has at least one argument. This can be
;; regarded as an optimization, but it is more
;; important for simplifying compilation of
;; MV-COMBINATIONS.
- (make-combination fun-cont))))
- (ir1-convert start fun-cont
+ (make-combination fun-lvar))))
+ (ir1-convert start fun-ctran fun-lvar
(if (and (consp fun) (eq (car fun) 'function))
fun
`(%coerce-callable-to-fun ,fun)))
- (setf (continuation-dest fun-cont) node)
- (collect ((arg-conts))
- (let ((this-start fun-cont))
+ (setf (lvar-dest fun-lvar) node)
+ (collect ((arg-lvars))
+ (let ((this-start fun-ctran))
(dolist (arg args)
- (let ((this-cont (make-continuation node)))
- (ir1-convert this-start this-cont arg)
- (setq this-start this-cont)
- (arg-conts this-cont)))
- (link-node-to-previous-continuation node this-start)
- (use-continuation node cont)
- (setf (basic-combination-args node) (arg-conts))))))
+ (let ((this-ctran (make-ctran))
+ (this-lvar (make-lvar node)))
+ (ir1-convert this-start this-ctran this-lvar arg)
+ (setq this-start this-ctran)
+ (arg-lvars this-lvar)))
+ (link-node-to-previous-ctran node this-start)
+ (use-continuation node next result)
+ (setf (basic-combination-args node) (arg-lvars))))))
;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
;;; the result code use result continuation (CONT), but transfer
;;; Nested MV-PROG1's work because during conversion of the result
;;; form, we use dummy continuation whose block is the true control
;;; destination.
-(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
+(def-ir1-translator multiple-value-prog1
+ ((values-form &rest forms) start next result)
#!+sb-doc
"MULTIPLE-VALUE-PROG1 Values-Form Form*
Evaluate Values-Form and then the Forms, but return all the values of
Values-Form."
- (continuation-starts-block cont)
- (let* ((dummy-result (make-continuation))
- (dummy-start (make-continuation))
- (cont-block (continuation-block cont)))
- (continuation-starts-block dummy-start)
- (ir1-convert start dummy-start result)
-
- (substitute-continuation-uses cont dummy-start)
-
- (continuation-starts-block dummy-result)
- (ir1-convert-progn-body dummy-start dummy-result forms)
- (let ((end-block (continuation-block dummy-result)))
- (dolist (pred (block-pred end-block))
- (unlink-blocks pred end-block)
- (link-blocks pred cont-block))
- (aver (not (continuation-dest dummy-result)))
- (delete-continuation dummy-result)
- (remove-from-dfo end-block))))
+ (let ((dummy (make-ctran)))
+ (ir1-convert start dummy result values-form)
+ (ir1-convert-progn-body dummy next nil forms)))
\f
;;;; interface to defining macros
(eq (info :function :kind name) :function))
(let ((atype (info :function :assumed-type name)))
(dolist (ref (leaf-refs var))
- (let ((dest (continuation-dest (node-cont ref))))
+ (let ((dest (node-dest ref)))
(when (and (eq (node-component ref) component)
(combination-p dest)
- (eq (continuation-use (basic-combination-fun dest)) ref))
+ (eq (lvar-uses (basic-combination-fun dest)) ref))
(setq atype (note-fun-use dest atype)))))
(setf (info :function :assumed-type name) atype))))
;;; Return true for a CONTINUATION whose sole use is a reference to a
;;; constant leaf.
-(defun constant-continuation-p (thing)
- (and (continuation-p thing)
- (let ((use (principal-continuation-use thing)))
+(defun constant-lvar-p (thing)
+ (and (lvar-p thing)
+ (let ((use (principal-lvar-use thing)))
(and (ref-p use) (constant-p (ref-leaf use))))))
;;; Return the constant value for a continuation whose only use is a
;;; constant node.
-(declaim (ftype (function (continuation) t) continuation-value))
-(defun continuation-value (cont)
- (let ((use (principal-continuation-use cont)))
+(declaim (ftype (function (lvar) t) lvar-value))
+(defun lvar-value (lvar)
+ (let ((use (principal-lvar-use lvar)))
(constant-value (ref-leaf use))))
\f
;;;; interface for obtaining results of type inference
;;; The result value is cached in the CONTINUATION-%DERIVED-TYPE slot.
;;; If the slot is true, just return that value, otherwise recompute
;;; and stash the value there.
-#!-sb-fluid (declaim (inline continuation-derived-type))
-(defun continuation-derived-type (cont)
- (declare (type continuation cont))
- (or (continuation-%derived-type cont)
- (setf (continuation-%derived-type cont)
- (%continuation-derived-type cont))))
-(defun %continuation-derived-type (cont)
- (declare (type continuation cont))
- (ecase (continuation-kind cont)
- ((:block-start :deleted-block-start)
- (let ((uses (block-start-uses (continuation-block cont))))
- (if uses
- (do ((res (node-derived-type (first uses))
- (values-type-union (node-derived-type (first current))
- res))
- (current (rest uses) (rest current)))
- ((null current) res))
- *empty-type*)))
- (:inside-block
- (node-derived-type (continuation-use cont)))))
+#!-sb-fluid (declaim (inline lvar-derived-type))
+(defun lvar-derived-type (lvar)
+ (declare (type lvar lvar))
+ (or (lvar-%derived-type lvar)
+ (setf (lvar-%derived-type lvar)
+ (%lvar-derived-type lvar))))
+(defun %lvar-derived-type (lvar)
+ (declare (type lvar lvar))
+ (let ((uses (lvar-uses lvar)))
+ (cond ((null uses) *empty-type*)
+ ((listp uses)
+ (do ((res (node-derived-type (first uses))
+ (values-type-union (node-derived-type (first current))
+ res))
+ (current (rest uses) (rest current)))
+ ((null current) res)))
+ (t
+ (node-derived-type (lvar-uses lvar))))))
;;; Return the derived type for CONT's first value. This is guaranteed
;;; not to be a VALUES or FUNCTION type.
-(declaim (ftype (sfunction (continuation) ctype) continuation-type))
-(defun continuation-type (cont)
- (single-value-type (continuation-derived-type cont)))
+(declaim (ftype (sfunction (lvar) ctype) lvar-type))
+(defun lvar-type (lvar)
+ (single-value-type (lvar-derived-type lvar)))
;;; If CONT is an argument of a function, return a type which the
;;; function checks CONT for.
-#!-sb-fluid (declaim (inline continuation-externally-checkable-type))
-(defun continuation-externally-checkable-type (cont)
- (or (continuation-%externally-checkable-type cont)
- (%continuation-%externally-checkable-type cont)))
-(defun %continuation-%externally-checkable-type (cont)
- (declare (type continuation cont))
- (let ((dest (continuation-dest cont)))
- (if (not (and dest
- (combination-p dest)))
+#!-sb-fluid (declaim (inline lvar-externally-checkable-type))
+(defun lvar-externally-checkable-type (lvar)
+ (or (lvar-%externally-checkable-type lvar)
+ (%lvar-%externally-checkable-type lvar)))
+(defun %lvar-%externally-checkable-type (lvar)
+ (declare (type lvar lvar))
+ (let ((dest (lvar-dest lvar)))
+ (if (not (and dest (combination-p dest)))
;; TODO: MV-COMBINATION
- (setf (continuation-%externally-checkable-type cont) *wild-type*)
+ (setf (lvar-%externally-checkable-type lvar) *wild-type*)
(let* ((fun (combination-fun dest))
(args (combination-args dest))
- (fun-type (continuation-type fun)))
- (setf (continuation-%externally-checkable-type fun) *wild-type*)
+ (fun-type (lvar-type fun)))
+ (setf (lvar-%externally-checkable-type fun) *wild-type*)
(if (or (not (call-full-like-p dest))
(not (fun-type-p fun-type))
;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
(fun-type-wild-args fun-type))
(dolist (arg args)
(when arg
- (setf (continuation-%externally-checkable-type arg)
+ (setf (lvar-%externally-checkable-type arg)
*wild-type*)))
(map-combination-args-and-types
(lambda (arg type)
- (setf (continuation-%externally-checkable-type arg)
- (acond ((continuation-%externally-checkable-type arg)
+ (setf (lvar-%externally-checkable-type arg)
+ (acond ((lvar-%externally-checkable-type arg)
(values-type-intersection
it (coerce-to-values type)))
(t (coerce-to-values type)))))
dest)))))
- (continuation-%externally-checkable-type cont))
-(declaim (inline flush-continuation-externally-checkable-type))
-(defun flush-continuation-externally-checkable-type (cont)
- (declare (type continuation cont))
- (setf (continuation-%externally-checkable-type cont) nil))
+ (lvar-%externally-checkable-type lvar))
+#!-sb-fluid(declaim (inline flush-lvar-externally-checkable-type))
+(defun flush-lvar-externally-checkable-type (lvar)
+ (declare (type lvar lvar))
+ (setf (lvar-%externally-checkable-type lvar) nil))
\f
;;;; interface routines used by optimizers
;;; This function is called by optimizers to indicate that something
-;;; interesting has happened to the value of CONT. Optimizers must
+;;; interesting has happened to the value of LVAR. Optimizers must
;;; make sure that they don't call for reoptimization when nothing has
;;; happened, since optimization will fail to terminate.
;;;
-;;; We clear any cached type for the continuation and set the
-;;; reoptimize flags on everything in sight, unless the continuation
-;;; is deleted (in which case we do nothing.)
-;;;
-;;; Since this can get called during IR1 conversion, we have to be
-;;; careful not to fly into space when the DEST's PREV is missing.
-(defun reoptimize-continuation (cont)
- (declare (type continuation cont))
- (setf (continuation-%derived-type cont) nil)
- (unless (member (continuation-kind cont) '(:deleted :unused))
- (let ((dest (continuation-dest cont)))
+;;; We clear any cached type for the lvar and set the reoptimize flags
+;;; on everything in sight.
+(defun reoptimize-lvar (lvar)
+ (declare (type (or lvar null) lvar))
+ (when lvar
+ (setf (lvar-%derived-type lvar) nil)
+ (let ((dest (lvar-dest lvar)))
(when dest
- (setf (continuation-reoptimize cont) t)
- (setf (node-reoptimize dest) t)
- (let ((prev (node-prev dest)))
- (when prev
- (let* ((block (continuation-block prev))
- (component (block-component block)))
- (when (typep dest 'cif)
- (setf (block-test-modified block) t))
- (setf (block-reoptimize block) t)
- (setf (component-reoptimize component) t))))))
- (do-uses (node cont)
+ (setf (lvar-reoptimize lvar) t)
+ (setf (node-reoptimize dest) t)
+ (binding* (;; Since this may be called during IR1 conversion,
+ ;; PREV may be missing.
+ (prev (node-prev dest) :exit-if-null)
+ (block (ctran-block prev))
+ (component (block-component block)))
+ (when (typep dest 'cif)
+ (setf (block-test-modified block) t))
+ (setf (block-reoptimize block) t)
+ (setf (component-reoptimize component) t))))
+ (do-uses (node lvar)
(setf (block-type-check (node-block node)) t)))
(values))
-(defun reoptimize-continuation-uses (cont)
- (declare (type continuation cont))
- (dolist (use (find-uses cont))
+(defun reoptimize-lvar-uses (lvar)
+ (declare (type lvar lvar))
+ (do-uses (use lvar)
(setf (node-reoptimize use) t)
(setf (block-reoptimize (node-block use)) t)
(setf (component-reoptimize (node-component use)) t)))
;;;
;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the
;;; intersection is different from the old type, then we do a
-;;; REOPTIMIZE-CONTINUATION on the NODE-CONT.
+;;; REOPTIMIZE-LVAR on the NODE-LVAR.
(defun derive-node-type (node rtype)
- (declare (type node node) (type ctype rtype))
+ (declare (type valued-node node) (type ctype rtype))
(let ((node-type (node-derived-type node)))
(unless (eq node-type rtype)
(let ((int (values-type-intersection node-type rtype))
- (cont (node-cont node)))
+ (lvar (node-lvar node)))
(when (type/= node-type int)
(when (and *check-consistency*
(eq int *empty-type*)
~% ~S~%*** possible internal error? Please report this."
(type-specifier rtype) (type-specifier node-type))))
(setf (node-derived-type node) int)
+ ;; If the new type consists of only one object, replace the
+ ;; node with a constant reference.
(when (and (ref-p node)
(lambda-var-p (ref-leaf node)))
(let ((type (single-value-type int)))
(null (rest (member-type-members type))))
(change-ref-leaf node (find-constant
(first (member-type-members type)))))))
- (reoptimize-continuation cont)))))
+ (reoptimize-lvar lvar)))))
(values))
;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
-;;; error for CONT's value not to be TYPEP to TYPE. We implement it
-;;; splitting off DEST a new CAST node. If we improve the assertion,
-;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new
-;;; assertion will be checked. We return the new "argument"
-;;; continuation of DEST.
-(defun assert-continuation-type (cont type policy)
- (declare (type continuation cont) (type ctype type))
- (if (values-subtypep (continuation-derived-type cont) type)
- cont
- (let* ((dest (continuation-dest cont))
- (prev-cont (node-prev dest)))
- (aver dest)
- (with-ir1-environment-from-node dest
- (let* ((cast (make-cast cont type policy))
- (checked-value (make-continuation)))
- (setf (continuation-next prev-cont) cast
- (node-prev cast) prev-cont)
- (use-continuation cast checked-value)
- (link-node-to-previous-continuation dest checked-value)
- (substitute-continuation checked-value cont)
- (setf (continuation-dest cont) cast)
- (reoptimize-continuation cont)
- checked-value)))))
+;;; error for LVAR's value not to be TYPEP to TYPE. We implement it
+;;; splitting off DEST a new CAST node; old LVAR will deliver values
+;;; to CAST. If we improve the assertion, we set TYPE-CHECK and
+;;; TYPE-ASSERTED to guarantee that the new assertion will be checked.
+(defun assert-lvar-type (lvar type policy)
+ (declare (type lvar lvar) (type ctype type))
+ (unless (values-subtypep (lvar-derived-type lvar) type)
+ (let* ((dest (lvar-dest lvar))
+ (ctran (node-prev dest)))
+ (with-ir1-environment-from-node dest
+ (let* ((cast (make-cast lvar type policy))
+ (internal-lvar (make-lvar))
+ (internal-ctran (make-ctran)))
+ (setf (ctran-next ctran) cast
+ (node-prev cast) ctran)
+ (use-continuation cast internal-ctran internal-lvar)
+ (link-node-to-previous-ctran dest internal-ctran)
+ (substitute-lvar internal-lvar lvar)
+ (setf (lvar-dest lvar) cast)
+ (reoptimize-lvar lvar)
+ (when (return-p dest)
+ (node-ends-block cast))
+ (setf (block-attributep (block-flags (node-block cast))
+ type-check type-asserted)
+ t))))))
\f
;;;; IR1-OPTIMIZE
;; optimization, not after. This ensures that the node or block will
;; be reoptimized if necessary.
(setf (block-reoptimize block) nil)
- (do-nodes (node cont block :restart-p t)
+ (do-nodes (node nil block :restart-p t)
(when (node-reoptimize node)
;; As above, we clear the node REOPTIMIZE flag before optimizing.
(setf (node-reoptimize node) nil)
(ir1-optimize-mv-combination node))
(exit
;; With an EXIT, we derive the node's type from the VALUE's
- ;; type. We don't propagate CONT's assertion to the VALUE,
- ;; since if we did, this would move the checking of CONT's
- ;; assertion to the exit. This wouldn't work with CATCH and
- ;; UWP, where the EXIT node is just a placeholder for the
- ;; actual unknown exit.
+ ;; type.
(let ((value (exit-value node)))
(when value
- (derive-node-type node (continuation-derived-type value)))))
+ (derive-node-type node (lvar-derived-type value)))))
(cset
(ir1-optimize-set node))
(cast
(defun join-successor-if-possible (block)
(declare (type cblock block))
(let ((next (first (block-succ block))))
- (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker
- (let* ((last (block-last block))
- (last-cont (node-cont last))
- (next-cont (block-start next)))
- (cond (;; We cannot combine with a successor block if:
- (or
- ;; The successor has more than one predecessor.
- (rest (block-pred next))
- ;; The last node's CONT is also used somewhere else.
- ;; (as in (IF <cond> (M-V-PROG1 ...) (M-V-PROG1 ...)))
- (not (eq (continuation-use last-cont) last))
- ;; The successor is the current block (infinite loop).
- (eq next block)
- ;; The next block has a different cleanup, and thus
- ;; we may want to insert cleanup code between the
- ;; two blocks at some point.
- (not (eq (block-end-cleanup block)
- (block-start-cleanup next)))
- ;; The next block has a different home lambda, and
- ;; thus the control transfer is a non-local exit.
- (not (eq (block-home-lambda block)
- (block-home-lambda next))))
- nil)
- ;; Joining is easy when the successor's START
- ;; continuation is the same from our LAST's CONT.
- ((eq last-cont next-cont)
- (join-blocks block next)
- t)
- ;; If they differ, then we can still join when the last
- ;; continuation has no next and the next continuation
- ;; has no uses.
- ((and (null (block-start-uses next))
- (eq (continuation-kind last-cont) :inside-block))
- ;; In this case, we replace the next
- ;; continuation with the last before joining the blocks.
- (let ((next-node (continuation-next next-cont)))
- ;; If NEXT-CONT does have a dest, it must be
- ;; unreachable, since there are no USES.
- ;; DELETE-CONTINUATION will mark the dest block as
- ;; DELETE-P [and also this block, unless it is no
- ;; longer backward reachable from the dest block.]
- (delete-continuation next-cont)
- (setf (node-prev next-node) last-cont)
- (setf (continuation-next last-cont) next-node)
- (setf (block-start next) last-cont)
- (join-blocks block next))
- t)
- ((and (null (block-start-uses next))
- (not (typep (continuation-dest last-cont)
- '(or exit creturn)))
- (null (continuation-lexenv-uses last-cont)))
- (assert (null (find-uses next-cont)))
- (when (continuation-dest last-cont)
- (substitute-continuation next-cont last-cont))
- (delete-continuation-use last)
- (add-continuation-use last next-cont)
- (setf (continuation-%derived-type next-cont) nil)
- (join-blocks block next)
- t)
- (t
- nil))))))
-
-;;; Join together two blocks which have the same ending/starting
-;;; continuation. The code in BLOCK2 is moved into BLOCK1 and BLOCK2
-;;; is deleted from the DFO. We combine the optimize flags for the two
-;;; blocks so that any indicated optimization gets done.
+ (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker
+ (cond ( ;; We cannot combine with a successor block if:
+ (or
+ ;; The successor has more than one predecessor.
+ (rest (block-pred next))
+ ;; The successor is the current block (infinite loop).
+ (eq next block)
+ ;; The next block has a different cleanup, and thus
+ ;; we may want to insert cleanup code between the
+ ;; two blocks at some point.
+ (not (eq (block-end-cleanup block)
+ (block-start-cleanup next)))
+ ;; The next block has a different home lambda, and
+ ;; thus the control transfer is a non-local exit.
+ (not (eq (block-home-lambda block)
+ (block-home-lambda next))))
+ nil)
+ (t
+ (join-blocks block next)
+ t)))))
+
+;;; Join together two blocks. The code in BLOCK2 is moved into BLOCK1
+;;; and BLOCK2 is deleted from the DFO. We combine the optimize flags
+;;; for the two blocks so that any indicated optimization gets done.
(defun join-blocks (block1 block2)
(declare (type cblock block1 block2))
- (let* ((last (block-last block2))
- (last-cont (node-cont last))
+ (let* ((last1 (block-last block1))
+ (last2 (block-last block2))
(succ (block-succ block2))
(start2 (block-start block2)))
- (do ((cont start2 (node-cont (continuation-next cont))))
- ((eq cont last-cont)
- (when (eq (continuation-kind last-cont) :inside-block)
- (setf (continuation-block last-cont) block1)))
- (setf (continuation-block cont) block1))
+ (do ((ctran start2 (node-next (ctran-next ctran))))
+ ((not ctran))
+ (setf (ctran-block ctran) block1))
(unlink-blocks block1 block2)
(dolist (block succ)
(unlink-blocks block2 block)
(link-blocks block1 block))
- (setf (block-last block1) last)
- (setf (continuation-kind start2) :inside-block))
+ (setf (ctran-kind start2) :inside-block)
+ (setf (node-next last1) start2)
+ (setf (ctran-use start2) last1)
+ (setf (block-last block1) last2))
(setf (block-flags block1)
(attributes-union (block-flags block1)
;;; variable has no references.
(defun flush-dead-code (block)
(declare (type cblock block))
- (do-nodes-backwards (node cont block)
- (unless (continuation-dest cont)
+ (setf (block-flush-p block) nil)
+ (do-nodes-backwards (node lvar block)
+ (unless lvar
(typecase node
(ref
(delete-ref node)
(null (leaf-refs var)))
(flush-dest (set-value node))
(setf (basic-var-sets var)
- (delete node (basic-var-sets var)))
+ (delq node (basic-var-sets var)))
(unlink-node node))))
(cast
(unless (cast-type-check node)
(flush-dest (cast-value node))
(unlink-node node))))))
- (setf (block-flush-p block) nil)
(values))
\f
;;;; local call return type propagation
(setf (tail-set-type tails) (res))
(dolist (fun (tail-set-funs tails))
(dolist (ref (leaf-refs fun))
- (reoptimize-continuation (node-cont ref)))))))
+ (reoptimize-lvar (node-lvar ref)))))))
(values))
\f
(let ((test (if-test node))
(block (node-block node)))
- (when (and (eq (block-start block) test)
- (eq (continuation-next test) node)
- (rest (block-start-uses block)))
+ (when (and (eq (block-start-node block) node)
+ (listp (lvar-uses test)))
(do-uses (use test)
(when (immediately-used-p test use)
(convert-if-if use node)
- (when (continuation-use test) (return)))))
+ (when (not (listp (lvar-uses test))) (return)))))
- (let* ((type (continuation-type test))
+ (let* ((type (lvar-type test))
(victim
- (cond ((constant-continuation-p test)
- (if (continuation-value test)
+ (cond ((constant-lvar-p test)
+ (if (lvar-value test)
(if-alternative node)
(if-consequent node)))
((not (types-equal-or-intersect type (specifier-type 'null)))
(cblock (if-consequent node))
(ablock (if-alternative node))
(use-block (node-block use))
- (dummy-cont (make-continuation))
- (new-cont (make-continuation))
- (new-node (make-if :test new-cont
+ (new-ctran (make-ctran))
+ (new-lvar (make-lvar))
+ (new-node (make-if :test new-lvar
:consequent cblock
:alternative ablock))
- (new-block (continuation-starts-block new-cont)))
- (link-node-to-previous-continuation new-node new-cont)
- (setf (continuation-dest new-cont) new-node)
- (flush-continuation-externally-checkable-type new-cont)
- (add-continuation-use new-node dummy-cont)
+ (new-block (ctran-starts-block new-ctran)))
+ (link-node-to-previous-ctran new-node new-ctran)
+ (setf (lvar-dest new-lvar) new-node)
(setf (block-last new-block) new-node)
(unlink-blocks use-block block)
- (delete-continuation-use use)
- (add-continuation-use use new-cont)
+ (%delete-lvar-use use)
+ (add-lvar-use use new-lvar)
(link-blocks use-block new-block)
(link-blocks new-block cblock)
(push "<IF Duplication>" (node-source-path node))
(push "<IF Duplication>" (node-source-path new-node))
- (reoptimize-continuation test)
- (reoptimize-continuation new-cont)
+ (reoptimize-lvar test)
+ (reoptimize-lvar new-lvar)
(setf (component-reanalyze *current-component*) t)))
(values))
\f
;;; anything, since there is nothing to be done.
;;; -- If the exit node and its ENTRY have the same home lambda then
;;; we know the exit is local, and can delete the exit. We change
-;;; uses of the Exit-Value to be uses of the original continuation,
+;;; uses of the Exit-Value to be uses of the original lvar,
;;; then unlink the node. If the exit is to a TR context, then we
;;; must do MERGE-TAIL-SETS on any local calls which delivered
;;; their value to this exit.
(defun maybe-delete-exit (node)
(declare (type exit node))
(let ((value (exit-value node))
- (entry (exit-entry node))
- (cont (node-cont node)))
+ (entry (exit-entry node)))
(when (and entry
(eq (node-home-lambda node) (node-home-lambda entry)))
- (setf (entry-exits entry) (delete node (entry-exits entry)))
+ (setf (entry-exits entry) (delq node (entry-exits entry)))
(if value
- (delete-filter node cont value)
+ (delete-filter node (node-lvar node) value)
(unlink-node node)))))
\f
;;; Do IR1 optimizations on a COMBINATION node.
(declaim (ftype (function (combination) (values)) ir1-optimize-combination))
(defun ir1-optimize-combination (node)
- (when (continuation-reoptimize (basic-combination-fun node))
+ (when (lvar-reoptimize (basic-combination-fun node))
(propagate-fun-change node))
(let ((args (basic-combination-args node))
(kind (basic-combination-kind node)))
((:full :error)
(dolist (arg args)
(when arg
- (setf (continuation-reoptimize arg) nil))))
+ (setf (lvar-reoptimize arg) nil))))
(t
(dolist (arg args)
(when arg
- (setf (continuation-reoptimize arg) nil)))
+ (setf (lvar-reoptimize arg) nil)))
(let ((attr (fun-info-attributes kind)))
(when (and (ir1-attributep attr foldable)
;; CALL attributes when they're actually passed
;; function arguments. -- WHN 19990918
(not (ir1-attributep attr call))
- (every #'constant-continuation-p args)
- (continuation-dest (node-cont node))
+ (every #'constant-lvar-p args)
+ (node-lvar node)
;; Even if the function is foldable in principle,
;; it might be one of our low-level
;; implementation-specific functions. Such
(or (fboundp (combination-fun-source-name node))
(progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%"
(combination-fun-source-name node)
- (mapcar #'continuation-value args))
+ (mapcar #'lvar-value args))
nil)))
(constant-fold-call node)
(return-from ir1-optimize-combination)))
(dolist (x (fun-info-transforms kind))
#!+sb-show
(when *show-transforms-p*
- (let* ((cont (basic-combination-fun node))
- (fname (continuation-fun-name cont t)))
+ (let* ((lvar (basic-combination-fun node))
+ (fname (lvar-fun-name lvar t)))
(/show "trying transform" x (transform-function x) "for" fname)))
(unless (ir1-transform node x)
#!+sb-show
;;; -- We are in IR1 conversion (where THE assertions are subject to
;;; weakening.) FIXME: Now THE assertions are not weakened, but new
;;; uses can(?) be added later. -- APD, 2003-07-17
+;;;
+;;; Why do we need to consider LVAR type? -- APD, 2003-07-30
(defun maybe-terminate-block (node ir1-converting-not-optimizing-p)
(declare (type (or basic-combination cast) node))
(let* ((block (node-block node))
- (cont (node-cont node))
+ (lvar (node-lvar node))
+ (ctran (node-next node))
(tail (component-tail (block-component block)))
(succ (first (block-succ block))))
(unless (or (and (eq node (block-last block)) (eq succ tail))
(block-delete-p block))
- (when (or (and (not (or ir1-converting-not-optimizing-p
- (eq (continuation-kind cont) :deleted)))
- (eq (continuation-derived-type cont) *empty-type*))
- (eq (node-derived-type node) *empty-type*))
+ (when (eq (node-derived-type node) *empty-type*)
(cond (ir1-converting-not-optimizing-p
- (delete-continuation-use node)
(cond
- ((block-last block)
- (aver (and (eq (block-last block) node)
- (eq (continuation-kind cont) :block-start))))
- (t
- (setf (block-last block) node)
- (link-blocks block (continuation-starts-block cont)))))
+ ((block-last block)
+ (aver (eq (block-last block) node)))
+ (t
+ (setf (block-last block) node)
+ (setf (ctran-use ctran) nil)
+ (setf (ctran-kind ctran) :unused)
+ (setf (ctran-block ctran) nil)
+ (setf (node-next node) nil)
+ (link-blocks block (ctran-starts-block ctran)))))
(t
- (node-ends-block node)
- (delete-continuation-use node)
- (if (eq (continuation-kind cont) :unused)
- (delete-continuation cont)
- (reoptimize-continuation cont))))
+ (node-ends-block node)))
(unlink-blocks block (first (block-succ block)))
(setf (component-reanalyze (block-component block)) t)
(aver (not (block-succ block)))
(link-blocks block tail)
- (add-continuation-use node (make-continuation))
+ (if ir1-converting-not-optimizing-p
+ (%delete-lvar-use node)
+ (delete-lvar-use node))
t))))
;;; This is called both by IR1 conversion and IR1 optimization when
;;; FUN-INFO assigned.
(defun recognize-known-call (call ir1-converting-not-optimizing-p)
(declare (type combination call))
- (let* ((ref (continuation-use (basic-combination-fun call)))
+ (let* ((ref (lvar-uses (basic-combination-fun call)))
(leaf (when (ref-p ref) (ref-leaf ref)))
(inlinep (if (defined-fun-p leaf)
(defined-fun-inlinep leaf)
(frob)
(locall-analyze-component *current-component*))))
- (values (ref-leaf (continuation-use (basic-combination-fun call)))
+ (values (ref-leaf (lvar-uses (basic-combination-fun call)))
nil))
(t
(let ((info (info :function :info (leaf-source-name leaf))))
(defun propagate-fun-change (call)
(declare (type combination call))
(let ((*compiler-error-context* call)
- (fun-cont (basic-combination-fun call)))
- (setf (continuation-reoptimize fun-cont) nil)
+ (fun-lvar (basic-combination-fun call)))
+ (setf (lvar-reoptimize fun-lvar) nil)
(case (combination-kind call)
(:local
(let ((fun (combination-lambda call)))
(derive-node-type call (tail-set-type (lambda-tail-set fun))))))
(:full
(multiple-value-bind (leaf info)
- (validate-call-type call (continuation-type fun-cont) nil)
+ (validate-call-type call (lvar-type fun-lvar) nil)
(cond ((functional-p leaf)
(convert-call-if-possible
- (continuation-use (basic-combination-fun call))
+ (lvar-uses (basic-combination-fun call))
call))
((not leaf))
((and (leaf-has-source-name-p leaf)
(and info
(ir1-attributep (fun-info-attributes info)
predicate)
- (let ((dest (continuation-dest (node-cont call))))
- (and dest (not (if-p dest)))))))
+ (let ((lvar (node-lvar call)))
+ (and lvar (not (if-p (lvar-dest lvar))))))))
(let ((name (leaf-source-name leaf))
(dummies (make-gensym-list
(length (combination-args call)))))
t))))
;;; When we don't like an IR1 transform, we throw the severity/reason
-;;; and args.
+;;; and args.
;;;
;;; GIVE-UP-IR1-TRANSFORM is used to throw out of an IR1 transform,
;;; aborting this attempt to transform the call, but admitting the
(as-debug-name
source-name
"<unknown function>"))))
- (ref (continuation-use (combination-fun call))))
+ (ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
(locall-analyze-component *current-component*))))
;;;
;;; If there is more than one value, then we transform the call into a
;;; VALUES form.
-;;;
-;;; An old commentary also said:
-;;;
-;;; We insert the resulting constant node after the call, stealing
-;;; the call's continuation. We give the call a continuation with no
-;;; DEST, which should cause it and its arguments to go away.
-;;;
-;;; This seems to be more efficient, than the current code. Maybe we
-;;; should really implement it? -- APD, 2002-12-23
(defun constant-fold-call (call)
- (let ((args (mapcar #'continuation-value (combination-args call)))
+ (let ((args (mapcar #'lvar-value (combination-args call)))
(fun-name (combination-fun-source-name call)))
(multiple-value-bind (values win)
(careful-call fun-name
"constant folding")
(cond ((not win)
(setf (combination-kind call) :error))
- ((and (proper-list-of-length-p values 1)
- (eq (continuation-kind (node-cont call)) :inside-block))
+ ((and (proper-list-of-length-p values 1))
(with-ir1-environment-from-node call
- (let* ((cont (node-cont call))
- (next (continuation-next cont))
- (prev (make-continuation)))
- (delete-continuation-use call)
- (add-continuation-use call prev)
- (reference-constant prev cont (first values))
- (setf (continuation-next cont) next)
- (let ((block (node-block call)))
- (when (eq (block-last block) call)
- (setf (block-last block) (continuation-next prev))))
- ;; FIXME: type checking?
- (reoptimize-continuation cont)
- (reoptimize-continuation prev)
+ (let* ((lvar (node-lvar call))
+ (prev (node-prev call))
+ (intermediate-ctran (make-ctran)))
+ (%delete-lvar-use call)
+ (setf (ctran-next prev) nil)
+ (setf (node-prev call) nil)
+ (reference-constant prev intermediate-ctran lvar
+ (first values))
+ (link-node-to-previous-ctran call intermediate-ctran)
+ (reoptimize-lvar lvar)
(flush-combination call))))
(t (let ((dummies (make-gensym-list (length args))))
(transform-call
(setf (leaf-type leaf) int)
(dolist (ref (leaf-refs leaf))
(derive-node-type ref (make-single-value-type int))
- (let* ((cont (node-cont ref))
- (dest (continuation-dest cont)))
- ;; KLUDGE: LET var substitution
- (when (combination-p dest)
- (reoptimize-continuation cont))))))
+ ;; KLUDGE: LET var substitution
+ (let* ((lvar (node-lvar ref)))
+ (when (and lvar (combination-p (lvar-dest lvar)))
+ (reoptimize-lvar lvar))))))
(values))))
;;; Iteration variable: exactly one SETQ of the form:
(binding* ((sets (lambda-var-sets var) :exit-if-null)
(set (first sets))
(() (null (rest sets)) :exit-if-null)
- (set-use (principal-continuation-use (set-value set)))
+ (set-use (principal-lvar-use (set-value set)))
(() (and (combination-p set-use)
(fun-info-p (combination-kind set-use))
(eq (combination-fun-source-name set-use) '+))
:exit-if-null)
(+-args (basic-combination-args set-use))
(() (and (proper-list-of-length-p +-args 2 2)
- (let ((first (principal-continuation-use
+ (let ((first (principal-lvar-use
(first +-args))))
(and (ref-p first)
(eq (ref-leaf first) var))))
:exit-if-null)
- (step-type (continuation-type (second +-args)))
- (set-type (continuation-type (set-value set))))
+ (step-type (lvar-type (second +-args)))
+ (set-type (lvar-type (set-value set))))
(when (and (numeric-type-p initial-type)
(numeric-type-p step-type)
(numeric-type-equal initial-type step-type))
:enumerable nil)))))
(deftransform + ((x y) * * :result result)
"check for iteration variable reoptimization"
- (let ((dest (principal-continuation-end result))
- (use (principal-continuation-use x)))
+ (let ((dest (principal-lvar-end result))
+ (use (principal-lvar-use x)))
(when (and (ref-p use)
(set-p dest)
(eq (ref-leaf use)
(set-var dest)))
- (reoptimize-continuation (set-value dest))))
+ (reoptimize-lvar (set-value dest))))
(give-up-ir1-transform))
;;; Figure out the type of a LET variable that has sets. We compute
(defun propagate-from-sets (var initial-type)
(collect ((res initial-type type-union))
(dolist (set (basic-var-sets var))
- (let ((type (continuation-type (set-value set))))
+ (let ((type (lvar-type (set-value set))))
(res type)
(when (node-reoptimize set)
(derive-node-type set (make-single-value-type type))
(let ((home (lambda-var-home var)))
(when (eq (functional-kind home) :let)
(let* ((initial-value (let-var-initial-value var))
- (initial-type (continuation-type initial-value)))
- (setf (continuation-reoptimize initial-value) nil)
+ (initial-type (lvar-type initial-value)))
+ (setf (lvar-reoptimize initial-value) nil)
(propagate-from-sets var initial-type))))))
(derive-node-type node (make-single-value-type
- (continuation-type (set-value node))))
+ (lvar-type (set-value node))))
(values))
;;; Return true if the value of REF will always be the same (and is
;;; If we have a non-set LET var with a single use, then (if possible)
;;; replace the variable reference's CONT with the arg continuation.
-;;; This is inhibited when:
-;;; -- CONT has other uses, or
-;;; -- the reference is in a different environment from the variable, or
-;;; -- CONT carries unknown number of values, or
-;;; -- DEST is return or exit, or
-;;; -- DEST is sensitive to the number of values and ARG return non-one value.
;;;
;;; We change the REF to be a reference to NIL with unused value, and
;;; let it be flushed as dead code. A side effect of this substitution
;;; is to delete the variable.
-(defun substitute-single-use-continuation (arg var)
- (declare (type continuation arg) (type lambda-var var))
- (let* ((ref (first (leaf-refs var)))
- (cont (node-cont ref))
- (dest (continuation-dest cont)))
- (when (and (eq (continuation-use cont) ref)
- dest
- (typecase dest
- (cast
- (and (type-single-value-p (continuation-derived-type arg))
- (multiple-value-bind (pdest pprev)
- (principal-continuation-end cont)
- (declare (ignore pdest))
- (continuation-single-value-p pprev))))
- (mv-combination
- (or (eq (basic-combination-fun dest) cont)
- (and (eq (basic-combination-kind dest) :local)
- (type-single-value-p (continuation-derived-type arg)))))
- ((or creturn exit)
- nil)
- (t
- ;; (AVER (CONTINUATION-SINGLE-VALUE-P CONT))
- t))
- (eq (node-home-lambda ref)
- (lambda-home (lambda-var-home var))))
- (aver (member (continuation-kind arg)
- '(:block-start :deleted-block-start :inside-block)))
+(defun substitute-single-use-lvar (arg var)
+ (declare (type lvar arg) (type lambda-var var))
+ (binding* ((ref (first (leaf-refs var)))
+ (lvar (node-lvar ref) :exit-if-null)
+ (dest (lvar-dest lvar)))
+ (when (and
+ ;; Think about (LET ((A ...)) (IF ... A ...)): two
+ ;; LVAR-USEs should not be met on one path.
+ (eq (lvar-uses lvar) ref)
+ (typecase dest
+ ;; we should not change lifetime of unknown values lvars
+ (cast
+ (and (type-single-value-p (lvar-derived-type arg))
+ (multiple-value-bind (pdest pprev)
+ (principal-lvar-end lvar)
+ (declare (ignore pdest))
+ (lvar-single-value-p pprev))))
+ (mv-combination
+ (or (eq (basic-combination-fun dest) lvar)
+ (and (eq (basic-combination-kind dest) :local)
+ (type-single-value-p (lvar-derived-type arg)))))
+ ((or creturn exit)
+ ;; While CRETURN and EXIT nodes may be known-values,
+ ;; they have their own complications, such as
+ ;; substitution into CRETURN may create new tail calls.
+ nil)
+ (t
+ (aver (lvar-single-value-p lvar))
+ t))
+ (eq (node-home-lambda ref)
+ (lambda-home (lambda-var-home var))))
(setf (node-derived-type ref) *wild-type*)
+ (substitute-lvar-uses lvar arg)
+ (delete-lvar-use ref)
(change-ref-leaf ref (find-constant nil))
- (substitute-continuation arg cont)
- (reoptimize-continuation arg)
+ (delete-ref ref)
+ (unlink-node ref)
+ (reoptimize-lvar lvar)
t)))
;;; Delete a LET, removing the call and bind nodes, and warning about
;;; If all of the variables are deleted (have no references) when we
;;; are done, then we delete the LET.
;;;
-;;; Note that we are responsible for clearing the
-;;; CONTINUATION-REOPTIMIZE flags.
+;;; Note that we are responsible for clearing the LVAR-REOPTIMIZE
+;;; flags.
(defun propagate-let-args (call fun)
(declare (type combination call) (type clambda fun))
(loop for arg in (combination-args call)
and var in (lambda-vars fun) do
- (when (and arg (continuation-reoptimize arg))
- (setf (continuation-reoptimize arg) nil)
+ (when (and arg (lvar-reoptimize arg))
+ (setf (lvar-reoptimize arg) nil)
(cond
- ((lambda-var-sets var)
- (propagate-from-sets var (continuation-type arg)))
- ((let ((use (continuation-use arg)))
- (when (ref-p use)
- (let ((leaf (ref-leaf use)))
- (when (and (constant-reference-p use)
- (csubtypep (leaf-type leaf)
- ;; (NODE-DERIVED-TYPE USE) would
- ;; be better -- APD, 2003-05-15
- (leaf-type var)))
- (propagate-to-refs var (continuation-type arg))
- (let ((use-component (node-component use)))
- (substitute-leaf-if
- (lambda (ref)
- (cond ((eq (node-component ref) use-component)
- t)
- (t
- (aver (lambda-toplevelish-p (lambda-home fun)))
- nil)))
- leaf var))
- t)))))
- ((and (null (rest (leaf-refs var)))
- (substitute-single-use-continuation arg var)))
- (t
- (propagate-to-refs var (continuation-type arg))))))
+ ((lambda-var-sets var)
+ (propagate-from-sets var (lvar-type arg)))
+ ((let ((use (lvar-uses arg)))
+ (when (ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (when (and (constant-reference-p use)
+ (csubtypep (leaf-type leaf)
+ ;; (NODE-DERIVED-TYPE USE) would
+ ;; be better -- APD, 2003-05-15
+ (leaf-type var)))
+ (propagate-to-refs var (lvar-type arg))
+ (let ((use-component (node-component use)))
+ (prog1 (substitute-leaf-if
+ (lambda (ref)
+ (cond ((eq (node-component ref) use-component)
+ t)
+ (t
+ (aver (lambda-toplevelish-p (lambda-home fun)))
+ nil)))
+ leaf var)))
+ t)))))
+ ((and (null (rest (leaf-refs var)))
+ (substitute-single-use-lvar arg var)))
+ (t
+ (propagate-to-refs var (lvar-type arg))))))
(when (every #'not (combination-args call))
(delete-let fun))
;;; If the function has an XEP, then we don't do anything, since we
;;; won't discover anything.
;;;
-;;; We can clear the CONTINUATION-REOPTIMIZE flags for arguments in
-;;; all calls corresponding to changed arguments in CALL, since the
-;;; only use in IR1 optimization of the REOPTIMIZE flag for local call
-;;; args is right here.
+;;; We can clear the LVAR-REOPTIMIZE flags for arguments in all calls
+;;; corresponding to changed arguments in CALL, since the only use in
+;;; IR1 optimization of the REOPTIMIZE flag for local call args is
+;;; right here.
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
(let* ((vars (lambda-vars fun))
(union (mapcar (lambda (arg var)
(when (and arg
- (continuation-reoptimize arg)
+ (lvar-reoptimize arg)
(null (basic-var-sets var)))
- (continuation-type arg)))
+ (lvar-type arg)))
(basic-combination-args call)
vars))
- (this-ref (continuation-use (basic-combination-fun call))))
+ (this-ref (lvar-use (basic-combination-fun call))))
(dolist (arg (basic-combination-args call))
(when arg
- (setf (continuation-reoptimize arg) nil)))
+ (setf (lvar-reoptimize arg) nil)))
(dolist (ref (leaf-refs fun))
- (let ((dest (continuation-dest (node-cont ref))))
+ (let ((dest (node-dest ref)))
(unless (or (eq ref this-ref) (not dest))
(setq union
(mapcar (lambda (this-arg old)
(when old
- (setf (continuation-reoptimize this-arg) nil)
- (type-union (continuation-type this-arg) old)))
+ (setf (lvar-reoptimize this-arg) nil)
+ (type-union (lvar-type this-arg) old)))
(basic-combination-args dest)
union)))))
- (mapc (lambda (var type)
- (when type
- (propagate-to-refs var type)))
- vars union)))
+ (loop for var in vars
+ and type in union
+ when type do (propagate-to-refs var type))))
(values))
\f
(defun ir1-optimize-mv-combination (node)
(ecase (basic-combination-kind node)
(:local
- (let ((fun-cont (basic-combination-fun node)))
- (when (continuation-reoptimize fun-cont)
- (setf (continuation-reoptimize fun-cont) nil)
+ (let ((fun-lvar (basic-combination-fun node)))
+ (when (lvar-reoptimize fun-lvar)
+ (setf (lvar-reoptimize fun-lvar) nil)
(maybe-let-convert (combination-lambda node))))
- (setf (continuation-reoptimize (first (basic-combination-args node))) nil)
+ (setf (lvar-reoptimize (first (basic-combination-args node))) nil)
(when (eq (functional-kind (combination-lambda node)) :mv-let)
(unless (convert-mv-bind-to-let node)
(ir1-optimize-mv-bind node))))
(:full
(let* ((fun (basic-combination-fun node))
- (fun-changed (continuation-reoptimize fun))
+ (fun-changed (lvar-reoptimize fun))
(args (basic-combination-args node)))
(when fun-changed
- (setf (continuation-reoptimize fun) nil)
- (let ((type (continuation-type fun)))
+ (setf (lvar-reoptimize fun) nil)
+ (let ((type (lvar-type fun)))
(when (fun-type-p type)
(derive-node-type node (fun-type-returns type))))
- (maybe-terminate-block node nil)
- (let ((use (continuation-use fun)))
+ (maybe-terminate-block node nil)
+ (let ((use (lvar-uses fun)))
(when (and (ref-p use) (functional-p (ref-leaf use)))
(convert-call-if-possible use node)
(when (eq (basic-combination-kind node) :local)
(maybe-let-convert (ref-leaf use))))))
(unless (or (eq (basic-combination-kind node) :local)
- (eq (continuation-fun-name fun) '%throw))
+ (eq (lvar-fun-name fun) '%throw))
(ir1-optimize-mv-call node))
(dolist (arg args)
- (setf (continuation-reoptimize arg) nil))))
+ (setf (lvar-reoptimize arg) nil))))
(:error))
(values))
(let* ((arg (first (basic-combination-args node)))
(vars (lambda-vars (combination-lambda node)))
(n-vars (length vars))
- (types (values-type-in (continuation-derived-type arg)
+ (types (values-type-in (lvar-derived-type arg)
n-vars)))
(loop for var in vars
and type in types
do (if (basic-var-sets var)
(propagate-from-sets var type)
(propagate-to-refs var type)))
- (setf (continuation-reoptimize arg) nil))
+ (setf (lvar-reoptimize arg) nil))
(values))
;;; If possible, convert a general MV call to an MV-BIND. We can do
(defun ir1-optimize-mv-call (node)
(let ((fun (basic-combination-fun node))
(*compiler-error-context* node)
- (ref (continuation-use (basic-combination-fun node)))
+ (ref (lvar-uses (basic-combination-fun node)))
(args (basic-combination-args node)))
(unless (and (ref-p ref) (constant-reference-p ref)
(return-from ir1-optimize-mv-call))
(multiple-value-bind (min max)
- (fun-type-nargs (continuation-type fun))
+ (fun-type-nargs (lvar-type fun))
(let ((total-nvals
(multiple-value-bind (types nvals)
- (values-types (continuation-derived-type (first args)))
+ (values-types (lvar-derived-type (first args)))
(declare (ignore types))
(if (eq nvals :unknown) nil nvals))))
;;; What we actually do is convert the VALUES combination into a
;;; normal LET combination calling the original :MV-LET lambda. If
;;; there are extra args to VALUES, discard the corresponding
-;;; continuations. If there are insufficient args, insert references
-;;; to NIL.
+;;; lvars. If there are insufficient args, insert references to NIL.
(defun convert-mv-bind-to-let (call)
(declare (type mv-combination call))
(let* ((arg (first (basic-combination-args call)))
- (use (continuation-use arg)))
+ (use (lvar-uses arg)))
(when (and (combination-p use)
- (eq (continuation-fun-name (combination-fun use))
+ (eq (lvar-fun-name (combination-fun use))
'values))
(let* ((fun (combination-lambda call))
(vars (lambda-vars fun))
(with-ir1-environment-from-node use
(let ((node-prev (node-prev use)))
(setf (node-prev use) nil)
- (setf (continuation-next node-prev) nil)
+ (setf (ctran-next node-prev) nil)
(collect ((res vals))
- (loop for cont = (make-continuation use)
- and prev = node-prev then cont
- repeat (- nvars nvals)
- do (reference-constant prev cont nil)
- (res cont))
- (setq vals (res)))
- (link-node-to-previous-continuation use
- (car (last vals)))))))
+ (loop for count below (- nvars nvals)
+ for prev = node-prev then ctran
+ for ctran = (make-ctran)
+ and lvar = (make-lvar use)
+ do (reference-constant prev ctran lvar nil)
+ (res lvar)
+ finally (link-node-to-previous-ctran
+ use ctran))
+ (setq vals (res)))))))
(setf (combination-args use) vals)
(flush-dest (combination-fun use))
- (let ((fun-cont (basic-combination-fun call)))
- (setf (continuation-dest fun-cont) use)
- (setf (combination-fun use) fun-cont)
- (flush-continuation-externally-checkable-type fun-cont))
+ (let ((fun-lvar (basic-combination-fun call)))
+ (setf (lvar-dest fun-lvar) use)
+ (setf (combination-fun use) fun-lvar)
+ (flush-lvar-externally-checkable-type fun-lvar))
(setf (combination-kind use) :local)
(setf (functional-kind fun) :let)
(flush-dest (first (basic-combination-args call)))
(unlink-node call)
(when vals
- (reoptimize-continuation (first vals)))
+ (reoptimize-lvar (first vals)))
(propagate-to-args use fun)
(reoptimize-call use))
t)))
;;;
;;; In implementation, this is somewhat similar to
;;; CONVERT-MV-BIND-TO-LET. We grab the args of LIST and make them
-;;; args of the VALUES-LIST call, flushing the old argument
-;;; continuation (allowing the LIST to be flushed.)
+;;; args of the VALUES-LIST call, flushing the old argument lvar
+;;; (allowing the LIST to be flushed.)
;;;
;;; FIXME: Thus we lose possible type assertions on (LIST ...).
(defoptimizer (values-list optimizer) ((list) node)
- (let ((use (continuation-use list)))
+ (let ((use (lvar-uses list)))
(when (and (combination-p use)
- (eq (continuation-fun-name (combination-fun use))
+ (eq (lvar-fun-name (combination-fun use))
'list))
;; FIXME: VALUES might not satisfy an assertion on NODE-CONT.
- (change-ref-leaf (continuation-use (combination-fun node))
+ (change-ref-leaf (lvar-uses (combination-fun node))
(find-free-fun 'values "in a strange place"))
(setf (combination-kind node) :full)
(let ((args (combination-args use)))
(dolist (arg args)
- (setf (continuation-dest arg) node)
- (flush-continuation-externally-checkable-type arg))
+ (setf (lvar-dest arg) node)
+ (flush-lvar-externally-checkable-type arg))
(setf (combination-args use) nil)
(flush-dest list)
(setf (combination-args node) args))
;;; to a PROG1. This allows the computation of the additional values
;;; to become dead code.
(deftransform values ((&rest vals) * * :node node)
- (unless (continuation-single-value-p (node-cont node))
+ (unless (lvar-single-value-p (node-lvar node))
(give-up-ir1-transform))
(setf (node-derived-type node) *wild-type*)
- (principal-continuation-single-valuify (node-cont node))
+ (principal-lvar-single-valuify (node-lvar node))
(if vals
(let ((dummies (make-gensym-list (length (cdr vals)))))
`(lambda (val ,@dummies)
(defun ir1-optimize-cast (cast &optional do-not-optimize)
(declare (type cast cast))
(let* ((value (cast-value cast))
- (value-type (continuation-derived-type value))
- (cont (node-cont cast))
- (dest (continuation-dest cont))
+ (value-type (lvar-derived-type value))
(atype (cast-asserted-type cast))
(int (values-type-intersection value-type atype)))
(derive-node-type cast int)
(unless (eq value-type *empty-type*)
;; FIXME: Do it in one step.
- (filter-continuation
+ (filter-lvar
value
`(multiple-value-call #'list 'dummy))
- (filter-continuation
- value
+ (filter-lvar
+ (cast-value cast)
;; FIXME: Derived type.
`(%compile-time-type-error 'dummy
',(type-specifier atype)
;; non-returning functions, so we declare the return type of
;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
;; here.
- (derive-node-type (continuation-use value) *empty-type*)
- (maybe-terminate-block (continuation-use value) nil)
+ (setq value (cast-value cast))
+ (derive-node-type (lvar-uses value) *empty-type*)
+ (maybe-terminate-block (lvar-uses value) nil)
;; FIXME: Is it necessary?
(aver (null (block-pred (node-block cast))))
(setf (block-delete-p (node-block cast)) t)
(when (eq (node-derived-type cast) *empty-type*)
(maybe-terminate-block cast nil))
- (when (and (not do-not-optimize)
- (values-subtypep value-type
- (cast-asserted-type cast)))
- (delete-filter cast cont value)
- (reoptimize-continuation cont)
- (when (continuation-single-value-p cont)
- (note-single-valuified-continuation cont))
- (when (not dest)
- (reoptimize-continuation-uses cont))
- (return-from ir1-optimize-cast t))
-
- (when (and (not do-not-optimize)
- (not (continuation-use value))
- dest)
- (collect ((merges))
- (do-uses (use value)
- (when (and (values-subtypep (node-derived-type use) atype)
- (immediately-used-p value use))
- (ensure-block-start cont)
- (delete-continuation-use use)
- (add-continuation-use use cont)
- (unlink-blocks (node-block use) (node-block cast))
- (link-blocks (node-block use)
- (first (block-succ (node-block cast))))
- (when (and (return-p dest)
- (basic-combination-p use)
- (eq (basic-combination-kind use) :local))
- (merges use))))
- (dolist (use (merges))
- (merge-tail-sets use))))
+ (when (not do-not-optimize)
+ (let ((lvar (node-lvar cast)))
+ (when (values-subtypep value-type (cast-asserted-type cast))
+ (delete-filter cast lvar value)
+ (when lvar
+ (reoptimize-lvar lvar)
+ (when (lvar-single-value-p lvar)
+ (note-single-valuified-lvar lvar)))
+ (return-from ir1-optimize-cast t))
+
+ (when (and (listp (lvar-uses value))
+ lvar)
+ ;; Pathwise removing of CAST
+ (let ((ctran (node-next cast))
+ (dest (lvar-dest lvar))
+ next-block)
+ (collect ((merges))
+ (do-uses (use value)
+ (when (and (values-subtypep (node-derived-type use) atype)
+ (immediately-used-p value use))
+ (unless next-block
+ (when ctran (ensure-block-start ctran))
+ (setq next-block (first (block-succ (node-block cast)))))
+ (%delete-lvar-use use)
+ (add-lvar-use use lvar)
+ (unlink-blocks (node-block use) (node-block cast))
+ (link-blocks (node-block use) next-block)
+ (when (and (return-p dest)
+ (basic-combination-p use)
+ (eq (basic-combination-kind use) :local))
+ (merges use))))
+ (dolist (use (merges))
+ (merge-tail-sets use)))))))
(when (and (cast-%type-check cast)
(values-subtypep value-type
(aver ep) ; else no entry points??
(multiple-value-bind (form context)
(find-original-source
- (node-source-path (continuation-next (block-start ep))))
+ (node-source-path (block-start-node ep)))
(declare (ignore form))
(let ((*print-level* 2)
(*print-pretty* nil))
;;; FIXME: This could and probably should be converted to use
;;; SOURCE-NAME and DEBUG-NAME. But I (WHN) don't use &AUX bindings,
;;; so I'm not motivated. Patches will be accepted...
-(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals)
- (declare (type continuation start cont) (list body aux-vars aux-vals))
+(defun ir1-convert-aux-bindings (start next result body aux-vars aux-vals)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (list body aux-vars aux-vals))
(if (null aux-vars)
- (ir1-convert-progn-body start cont body)
- (let ((fun-cont (make-continuation))
+ (ir1-convert-progn-body start next result body)
+ (let ((fun-ctran (make-ctran))
+ (fun-lvar (make-lvar))
(fun (ir1-convert-lambda-body body
(list (first aux-vars))
:aux-vars (rest aux-vars)
:debug-name (debug-namify
"&AUX bindings ~S"
aux-vars))))
- (reference-leaf start fun-cont fun)
- (ir1-convert-combination-args fun-cont cont
+ (reference-leaf start fun-ctran fun-lvar fun)
+ (ir1-convert-combination-args fun-ctran fun-lvar next result
(list (first aux-vals)))))
(values))
;;; will end up being the innermost one. We force CONT to start a
;;; block outside of this cleanup, causing cleanup code to be emitted
;;; when the scope is exited.
-(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars)
- (declare (type continuation start cont)
+(defun ir1-convert-special-bindings
+ (start next result body aux-vars aux-vals svars)
+ (declare (type ctran start next) (type (or lvar null) result)
(list body aux-vars aux-vals svars))
(cond
((null svars)
- (ir1-convert-aux-bindings start cont body aux-vars aux-vals))
+ (ir1-convert-aux-bindings start next result body aux-vars aux-vals))
(t
- (continuation-starts-block cont)
+ (ctran-starts-block next)
(let ((cleanup (make-cleanup :kind :special-bind))
(var (first svars))
- (next-cont (make-continuation))
- (nnext-cont (make-continuation)))
- (ir1-convert start next-cont
+ (bind-ctran (make-ctran))
+ (cleanup-ctran (make-ctran)))
+ (ir1-convert start bind-ctran nil
`(%special-bind ',(lambda-var-specvar var) ,var))
- (setf (cleanup-mess-up cleanup) (continuation-use next-cont))
+ (setf (cleanup-mess-up cleanup) (ctran-use bind-ctran))
(let ((*lexenv* (make-lexenv :cleanup cleanup)))
- (ir1-convert next-cont nnext-cont '(%cleanup-point))
- (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
+ (ir1-convert bind-ctran cleanup-ctran nil '(%cleanup-point))
+ (ir1-convert-special-bindings cleanup-ctran next result
+ body aux-vars aux-vals
(rest svars))))))
(values))
;;;
;;; AUX-VARS is a list of VAR structures for variables that are to be
;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
-;;; to get the initial value for the corresponding AUX-VAR.
+;;; to get the initial value for the corresponding AUX-VAR.
(defun ir1-convert-lambda-body (body
vars
&key
:bind bind
:%source-name source-name
:%debug-name debug-name))
- (result (make-continuation)))
+ (result-ctran (make-ctran))
+ (result-lvar (make-lvar)))
;; just to check: This function should fail internal assertions if
;; we didn't set up a valid debug name above.
(setf (bind-lambda bind) lambda)
(setf (node-lexenv bind) *lexenv*)
- (let ((block (continuation-starts-block result)))
- (let ((return (make-return :result result :lambda lambda))
- (tail-set (make-tail-set :funs (list lambda)))
- (dummy (make-continuation)))
+ (let ((block (ctran-starts-block result-ctran)))
+ (let ((return (make-return :result result-lvar :lambda lambda))
+ (tail-set (make-tail-set :funs (list lambda))))
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
- (setf (continuation-dest result) return)
- (setf (block-last block) return)
- (link-node-to-previous-continuation return result)
- (use-continuation return dummy))
+ (setf (lvar-dest result-lvar) return)
+ (link-node-to-previous-ctran return result-ctran)
+ (setf (block-last block) return))
(link-blocks block (component-tail *current-component*)))
(with-component-last-block (*current-component*
- (continuation-block result))
- (let ((cont1 (make-continuation))
- (cont2 (make-continuation)))
- (continuation-starts-block cont1)
- (link-node-to-previous-continuation bind cont1)
- (use-continuation bind cont2)
- (ir1-convert-special-bindings cont2 result body
+ (ctran-block result-ctran))
+ (let ((prebind-ctran (make-ctran))
+ (postbind-ctran (make-ctran)))
+ (ctran-starts-block prebind-ctran)
+ (link-node-to-previous-ctran bind prebind-ctran)
+ (use-ctran bind postbind-ctran)
+ (ir1-convert-special-bindings postbind-ctran result-ctran result-lvar
+ body
aux-vars aux-vals (svars))))))
(link-blocks (component-head *current-component*) (node-block bind))
(type optional-dispatch dispatcher))
(setf (functional-kind entry) :optional)
(setf (leaf-ever-used entry) t)
- (setf (lambda-optional-dispatch entry)
- dispatcher)
+ (setf (lambda-optional-dispatch entry) dispatcher)
entry)
;;; Create the actual entry-point function for an optional entry
;;; This function sets up the back link between the node and the
;;; continuation which continues at it.
-(defun link-node-to-previous-continuation (node cont)
- (declare (type node node) (type continuation cont))
- (aver (not (continuation-next cont)))
- (setf (continuation-next cont) node)
- (setf (node-prev node) cont))
+(defun link-node-to-previous-ctran (node ctran)
+ (declare (type node node) (type ctran ctran))
+ (aver (not (ctran-next ctran)))
+ (setf (ctran-next ctran) node)
+ (setf (node-prev node) ctran))
;;; This function is used to set the continuation for a node, and thus
;;; determine what receives the value and what is evaluated next. If
;;; our block and link it to that block. If the continuation is not
;;; currently used, then we set the DERIVED-TYPE for the continuation
;;; to that of the node, so that a little type propagation gets done.
-#!-sb-fluid (declaim (inline use-continuation))
-(defun use-continuation (node cont)
- (declare (type node node) (type continuation cont))
- (let ((node-block (continuation-block (node-prev node))))
- (case (continuation-kind cont)
- (:unused
- (setf (continuation-block cont) node-block)
- (setf (continuation-kind cont) :inside-block)
- (setf (continuation-use cont) node)
- (setf (node-cont node) cont))
- (t
- (%use-continuation node cont)))))
-(defun %use-continuation (node cont)
- (declare (type node node) (type continuation cont) (inline member))
- (let ((block (continuation-block cont))
- (node-block (continuation-block (node-prev node))))
- (aver (eq (continuation-kind cont) :block-start))
+#!-sb-fluid (declaim (inline use-ctran))
+(defun use-ctran (node ctran)
+ (declare (type node node) (type ctran ctran))
+ (if (eq (ctran-kind ctran) :unused)
+ (let ((node-block (ctran-block (node-prev node))))
+ (setf (ctran-block ctran) node-block)
+ (setf (ctran-kind ctran) :inside-block)
+ (setf (ctran-use ctran) node)
+ (setf (node-next node) ctran))
+ (%use-ctran node ctran)))
+(defun %use-ctran (node ctran)
+ (declare (type node node) (type ctran ctran) (inline member))
+ (let ((block (ctran-block ctran))
+ (node-block (ctran-block (node-prev node))))
+ (aver (eq (ctran-kind ctran) :block-start))
(when (block-last node-block)
(error "~S has already ended." node-block))
(setf (block-last node-block) node)
(when (memq node-block (block-pred block))
(error "~S is already a predecessor of ~S." node-block block))
(push node-block (block-pred block))
- (add-continuation-use node cont)
- (reoptimize-continuation cont)))
+ #+nil(reoptimize-ctran ctran))) ; XXX
+
+(defun use-lvar (node lvar)
+ (declare (type valued-node node) (type (or lvar null) lvar))
+ (aver (not (node-lvar node)))
+ (when lvar
+ (setf (node-lvar node) lvar)
+ (cond ((null (lvar-uses lvar))
+ (setf (lvar-uses lvar) node))
+ ((listp (lvar-uses lvar))
+ (aver (not (memq node (lvar-uses lvar))))
+ (push node (lvar-uses lvar)))
+ (t
+ (aver (neq node (lvar-uses lvar)))
+ (setf (lvar-uses lvar) (list node (lvar-uses lvar)))))
+ (reoptimize-lvar lvar)))
+
+#!-sb-fluid(declaim (inline use-continuation))
+(defun use-continuation (node ctran lvar)
+ (use-ctran node ctran)
+ (use-lvar node lvar))
\f
;;;; exported functions
\f
;;;; IR1-CONVERT, macroexpansion and special form dispatching
-(declaim (ftype (sfunction (continuation continuation t) (values))
+(declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
ir1-convert))
(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
;; out of the body and converts a proxy form instead.
- (ir1-error-bailout ((start
- cont
+ (ir1-error-bailout ((start next result
form
&optional
(proxy ``(error 'simple-program-error
(throw 'ir1-error-abort nil))))
,@body
(return-from ,skip nil)))
- (ir1-convert ,start ,cont ,proxy)))))
+ (ir1-convert ,start ,next ,result ,proxy)))))
;; Translate FORM into IR1. The code is inserted as the NEXT of the
- ;; continuation START. CONT is the continuation which receives the
- ;; value of the FORM to be translated. The translators call this
- ;; function recursively to translate their subnodes.
+ ;; CTRAN START. RESULT is the LVAR which receives the value of the
+ ;; FORM to be translated. The translators call this function
+ ;; recursively to translate their subnodes.
;;
;; As a special hack to make life easier in the compiler, a LEAF
;; IR1-converts into a reference to that LEAF structure. This allows
;; the creation using backquote of forms that contain leaf
;; references, without having to introduce dummy names into the
;; namespace.
- (defun ir1-convert (start cont form)
- (ir1-error-bailout (start cont form)
+ (defun ir1-convert (start next result form)
+ (ir1-error-bailout (start next result form)
(let ((*current-path* (or (gethash form *source-paths*)
(cons form *current-path*))))
(if (atom form)
(cond ((and (symbolp form) (not (keywordp form)))
- (ir1-convert-var start cont form))
+ (ir1-convert-var start next result form))
((leaf-p form)
- (reference-leaf start cont form))
+ (reference-leaf start next result form))
(t
- (reference-constant start cont form)))
+ (reference-constant start next result form)))
(let ((opname (car form)))
(cond ((or (symbolp opname) (leaf-p opname))
(let ((lexical-def (if (leaf-p opname)
opname
(lexenv-find opname funs))))
(typecase lexical-def
- (null (ir1-convert-global-functoid start cont form))
+ (null
+ (ir1-convert-global-functoid start next result
+ form))
(functional
- (ir1-convert-local-combination start
- cont
+ (ir1-convert-local-combination start next result
form
lexical-def))
(global-var
- (ir1-convert-srctran start cont lexical-def form))
+ (ir1-convert-srctran start next result
+ lexical-def form))
(t
(aver (and (consp lexical-def)
(eq (car lexical-def) 'macro)))
- (ir1-convert start cont
+ (ir1-convert start next result
(careful-expand-macro (cdr lexical-def)
form))))))
((or (atom opname) (not (eq (car opname) 'lambda)))
(t
;; implicitly (LAMBDA ..) because the LAMBDA
;; expression is the CAR of an executed form
- (ir1-convert-combination start
- cont
+ (ir1-convert-combination start next result
form
(ir1-convert-lambda
opname
;; if necessary. If we are producing a fasl file, make sure that
;; MAKE-LOAD-FORM gets used on any parts of the constant that it
;; needs to be.
- (defun reference-constant (start cont value)
- (declare (type continuation start cont)
+ (defun reference-constant (start next result value)
+ (declare (type ctran start next)
+ (type (or lvar null) result)
(inline find-constant))
(ir1-error-bailout
- (start cont value '(error "attempt to reference undumpable constant"))
+ (start next result value '(error "attempt to reference undumpable constant"))
(when (producing-fasl-file)
(maybe-emit-make-load-forms value))
(let* ((leaf (find-constant value))
(res (make-ref leaf)))
(push res (leaf-refs leaf))
- (link-node-to-previous-continuation res start)
- (use-continuation res cont)))
+ (link-node-to-previous-ctran res start)
+ (use-continuation res next result)))
(values)))
;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's
;;; needed. If LEAF represents a defined function which has already
;;; been converted, and is not :NOTINLINE, then reference the
;;; functional instead.
-(defun reference-leaf (start cont leaf)
- (declare (type continuation start cont) (type leaf leaf))
+(defun reference-leaf (start next result leaf)
+ (declare (type ctran start next) (type (or lvar null) result) (type leaf leaf))
(when (functional-p leaf)
(assure-functional-live-p leaf))
(let* ((type (lexenv-find leaf type-restrictions))
(ref (make-ref leaf)))
(push ref (leaf-refs leaf))
(setf (leaf-ever-used leaf) t)
- (link-node-to-previous-continuation ref start)
- (cond (type (let* ((ref-cont (make-continuation))
- (cast (make-cast ref-cont
+ (link-node-to-previous-ctran ref start)
+ (cond (type (let* ((ref-ctran (make-ctran))
+ (ref-lvar (make-lvar))
+ (cast (make-cast ref-lvar
(make-single-value-type type)
(lexenv-policy *lexenv*))))
- (setf (continuation-dest ref-cont) cast)
- (use-continuation ref ref-cont)
- (link-node-to-previous-continuation cast ref-cont)
- (use-continuation cast cont)))
- (t (use-continuation ref cont)))))
+ (setf (lvar-dest ref-lvar) cast)
+ (use-continuation ref ref-ctran ref-lvar)
+ (link-node-to-previous-ctran cast ref-ctran)
+ (use-continuation cast next result)))
+ (t (use-continuation ref next result)))))
;;; Convert a reference to a symbolic constant or variable. If the
;;; symbol is entered in the LEXENV-VARS we use that definition,
;;; otherwise we find the current global definition. This is also
;;; where we pick off symbol macro and alien variable references.
-(defun ir1-convert-var (start cont name)
- (declare (type continuation start cont) (symbol name))
+(defun ir1-convert-var (start next result name)
+ (declare (type ctran start next) (type (or lvar null) result) (symbol name))
(let ((var (or (lexenv-find name vars) (find-free-var name))))
(etypecase var
(leaf
(when (lambda-var-p var)
- (let ((home (continuation-home-lambda-or-null start)))
+ (let ((home (ctran-home-lambda-or-null start)))
(when home
(pushnew var (lambda-calls-or-closes home))))
(when (lambda-var-ignorep var)
;; (ANSI's specification for the IGNORE declaration requires
;; that this be a STYLE-WARNING, not a full WARNING.)
(compiler-style-warn "reading an ignored variable: ~S" name)))
- (reference-leaf start cont var))
+ (reference-leaf start next result var))
(cons
(aver (eq (car var) 'MACRO))
;; FIXME: [Free] type declarations. -- APD, 2002-01-26
- (ir1-convert start cont (cdr var)))
+ (ir1-convert start next result (cdr var)))
(heap-alien-info
- (ir1-convert start cont `(%heap-alien ',var)))))
+ (ir1-convert start next result `(%heap-alien ',var)))))
(values))
;;; Convert anything that looks like a special form, global function
;;; or compiler-macro call.
-(defun ir1-convert-global-functoid (start cont form)
- (declare (type continuation start cont) (list form))
+(defun ir1-convert-global-functoid (start next result form)
+ (declare (type ctran start next) (type (or lvar null) result) (list form))
(let* ((fun-name (first form))
(translator (info :function :ir1-convert fun-name))
(cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*)))
(cond (translator
(when cmacro-fun
(compiler-warn "ignoring compiler macro for special form"))
- (funcall translator start cont form))
+ (funcall translator start next result form))
((and cmacro-fun
;; gotcha: If you look up the DEFINE-COMPILER-MACRO
;; macro in the ANSI spec, you might think that
(let ((res (careful-expand-macro cmacro-fun form)))
(if (eq res form)
(ir1-convert-global-functoid-no-cmacro
- start cont form fun-name)
- (ir1-convert start cont res))))
+ start next result form fun-name)
+ (ir1-convert start next result res))))
(t
- (ir1-convert-global-functoid-no-cmacro start cont form fun-name)))))
+ (ir1-convert-global-functoid-no-cmacro start next result
+ form fun-name)))))
;;; Handle the case of where the call was not a compiler macro, or was
;;; a compiler macro and passed.
-(defun ir1-convert-global-functoid-no-cmacro (start cont form fun)
- (declare (type continuation start cont) (list form))
+(defun ir1-convert-global-functoid-no-cmacro (start next result form fun)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (list form))
;; FIXME: Couldn't all the INFO calls here be converted into
;; standard CL functions, like MACRO-FUNCTION or something?
;; And what happens with lexically-defined (MACROLET) macros
;; here, anyway?
(ecase (info :function :kind fun)
(:macro
- (ir1-convert start
- cont
+ (ir1-convert start next result
(careful-expand-macro (info :function :macro-function fun)
form)))
((nil :function)
- (ir1-convert-srctran start
- cont
+ (ir1-convert-srctran start next result
(find-free-fun fun "shouldn't happen! (no-cmacro)")
form))))
;;; Convert a bunch of forms, discarding all the values except the
;;; last. If there aren't any forms, then translate a NIL.
-(declaim (ftype (sfunction (continuation continuation list) (values))
+(declaim (ftype (sfunction (ctran ctran (or lvar null) list) (values))
ir1-convert-progn-body))
-(defun ir1-convert-progn-body (start cont body)
+(defun ir1-convert-progn-body (start next result body)
(if (endp body)
- (reference-constant start cont nil)
+ (reference-constant start next result nil)
(let ((this-start start)
(forms body))
(loop
(let ((form (car forms)))
(when (endp (cdr forms))
- (ir1-convert this-start cont form)
+ (ir1-convert this-start next result form)
(return))
- (let ((this-cont (make-continuation)))
- (ir1-convert this-start this-cont form)
- (setq this-start this-cont
+ (let ((this-ctran (make-ctran)))
+ (ir1-convert this-start this-ctran nil form)
+ (setq this-start this-ctran
forms (cdr forms)))))))
(values))
\f
;;; Convert a function call where the function FUN is a LEAF. FORM is
;;; the source for the call. We return the COMBINATION node so that
;;; the caller can poke at it if it wants to.
-(declaim (ftype (sfunction (continuation continuation list leaf) combination)
+(declaim (ftype (sfunction (ctran ctran (or lvar null) list leaf) combination)
ir1-convert-combination))
-(defun ir1-convert-combination (start cont form fun)
- (let ((fun-cont (make-continuation)))
- (ir1-convert start fun-cont `(the (or function symbol) ,fun))
- (ir1-convert-combination-args fun-cont cont (cdr form))))
+(defun ir1-convert-combination (start next result form fun)
+ (let ((fun-ctran (make-ctran))
+ (fun-lvar (make-lvar)))
+ (ir1-convert start fun-ctran fun-lvar `(the (or function symbol) ,fun))
+ (ir1-convert-combination-args fun-ctran fun-lvar next result (cdr form))))
;;; Convert the arguments to a call and make the COMBINATION
;;; node. FUN-CONT is the continuation which yields the function to
;;; call. ARGS is the list of arguments for the call, which defaults
;;; to the cdr of source. We return the COMBINATION node.
-(defun ir1-convert-combination-args (fun-cont cont args)
- (declare (type continuation fun-cont cont) (list args))
- (let ((node (make-combination fun-cont)))
- (setf (continuation-dest fun-cont) node)
- (collect ((arg-conts))
- (let ((this-start fun-cont))
+(defun ir1-convert-combination-args (fun-ctran fun-lvar next result args)
+ (declare (type ctran fun-ctran next)
+ (type lvar fun-lvar)
+ (type (or lvar null) result)
+ (list args))
+ (let ((node (make-combination fun-lvar)))
+ (setf (lvar-dest fun-lvar) node)
+ (collect ((arg-lvars))
+ (let ((this-start fun-ctran))
(dolist (arg args)
- (let ((this-cont (make-continuation node)))
- (ir1-convert this-start this-cont arg)
- (setq this-start this-cont)
- (arg-conts this-cont)))
- (link-node-to-previous-continuation node this-start)
- (use-continuation node cont)
- (setf (combination-args node) (arg-conts))))
+ (let ((this-ctran (make-ctran))
+ (this-lvar (make-lvar node)))
+ (ir1-convert this-start this-ctran this-lvar arg)
+ (setq this-start this-ctran)
+ (arg-lvars this-lvar)))
+ (link-node-to-previous-ctran node this-start)
+ (use-continuation node next result)
+ (setf (combination-args node) (arg-lvars))))
node))
;;; Convert a call to a global function. If not :NOTINLINE, then we do
;;; expansion, but is :INLINE, then give an efficiency note (unless a
;;; known function which will quite possibly be open-coded.) Next, we
;;; go to ok-combination conversion.
-(defun ir1-convert-srctran (start cont var form)
- (declare (type continuation start cont) (type global-var var))
+(defun ir1-convert-srctran (start next result var form)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (type global-var var))
(let ((inlinep (when (defined-fun-p var)
(defined-fun-inlinep var))))
(if (eq inlinep :notinline)
- (ir1-convert-combination start cont form var)
+ (ir1-convert-combination start next result form var)
(let ((transform (info :function
:source-transform
(leaf-source-name var))))
(if transform
- (multiple-value-bind (result pass) (funcall transform form)
+ (multiple-value-bind (transformed pass) (funcall transform form)
(if pass
- (ir1-convert-maybe-predicate start cont form var)
- (ir1-convert start cont result)))
- (ir1-convert-maybe-predicate start cont form var))))))
+ (ir1-convert-maybe-predicate start next result form var)
+ (ir1-convert start next result transformed)))
+ (ir1-convert-maybe-predicate start next result form var))))))
;;; If the function has the PREDICATE attribute, and the CONT's DEST
;;; isn't an IF, then we convert (IF <form> T NIL), ensuring that a
;;;
;;; If the function isn't a predicate, then we call
;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.
-(defun ir1-convert-maybe-predicate (start cont form var)
- (declare (type continuation start cont) (list form) (type global-var var))
+(defun ir1-convert-maybe-predicate (start next result form var)
+ (declare (type ctran start next)
+ (type (or lvar null) result)
+ (list form)
+ (type global-var var))
(let ((info (info :function :info (leaf-source-name var))))
(if (and info
(ir1-attributep (fun-info-attributes info) predicate)
- (not (if-p (continuation-dest cont))))
- (ir1-convert start cont `(if ,form t nil))
- (ir1-convert-combination-checking-type start cont form var))))
+ (not (if-p (and result (lvar-dest result)))))
+ (ir1-convert start next result `(if ,form t nil))
+ (ir1-convert-combination-checking-type start next result form var))))
;;; Actually really convert a global function call that we are allowed
;;; to early-bind.
;;; function type to the arg and result continuations. We do this now
;;; so that IR1 optimize doesn't have to redundantly do the check
;;; later so that it can do the type propagation.
-(defun ir1-convert-combination-checking-type (start cont form var)
- (declare (type continuation start cont) (list form) (type leaf var))
- (let* ((node (ir1-convert-combination start cont form var))
- (fun-cont (basic-combination-fun node))
+(defun ir1-convert-combination-checking-type (start next result form var)
+ (declare (type ctran start next) (type (or lvar null) result)
+ (list form)
+ (type leaf var))
+ (let* ((node (ir1-convert-combination start next result form var))
+ (fun-lvar (basic-combination-fun node))
(type (leaf-type var)))
(when (validate-call-type node type t)
- (setf (continuation-%derived-type fun-cont)
+ (setf (lvar-%derived-type fun-lvar)
(make-single-value-type type))
- (setf (continuation-reoptimize fun-cont) nil)))
+ (setf (lvar-reoptimize fun-lvar) nil)))
(values))
;;; Convert a call to a local function, or if the function has already
;;; LOCALL-ALREADY-LET-CONVERTED. The THROW should only happen when we
;;; are converting inline expansions for local functions during
;;; optimization.
-(defun ir1-convert-local-combination (start cont form functional)
+(defun ir1-convert-local-combination (start next result form functional)
(assure-functional-live-p functional)
- (ir1-convert-combination start
- cont
+ (ir1-convert-combination start next result
form
(maybe-reanalyze-functional functional)))
\f
;;; Process a single declaration spec, augmenting the specified LEXENV
;;; RES. Return RES and result type. VARS and FVARS are as described
-;;; in PROCESS-DECLS.
+;;; PROCESS-DECLS.
(defun process-1-decl (raw-spec res vars fvars)
(declare (type list raw-spec vars fvars))
(declare (type lexenv res))
(values-type-intersection result-type new-result-type))))))
(values env result-type)))
-(defun %processing-decls (decls vars fvars cont fun)
+(defun %processing-decls (decls vars fvars ctran lvar fun)
(multiple-value-bind (*lexenv* result-type)
(process-decls decls vars fvars)
(cond ((eq result-type *wild-type*)
- (funcall fun cont))
+ (funcall fun ctran lvar))
(t
- (let ((value-cont (make-continuation)))
+ (let ((value-ctran (make-ctran))
+ (value-lvar (make-lvar)))
(multiple-value-prog1
- (funcall fun value-cont)
- (let ((cast (make-cast value-cont result-type
+ (funcall fun value-ctran value-lvar)
+ (let ((cast (make-cast value-lvar result-type
(lexenv-policy *lexenv*))))
- (link-node-to-previous-continuation cast value-cont)
- (setf (continuation-dest value-cont) cast)
- (use-continuation cast cont))))))))
-(defmacro processing-decls ((decls vars fvars cont) &body forms)
- (check-type cont symbol)
- `(%processing-decls ,decls ,vars ,fvars ,cont
- (lambda (,cont) ,@forms)))
+ (link-node-to-previous-ctran cast value-ctran)
+ (setf (lvar-dest value-lvar) cast)
+ (use-continuation cast ctran lvar))))))))
+(defmacro processing-decls ((decls vars fvars ctran lvar) &body forms)
+ (check-type ctran symbol)
+ (check-type lvar symbol)
+ `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
+ (lambda (,ctran ,lvar) ,@forms)))
;;; Return the SPECVAR for NAME to use when we see a local SPECIAL
;;; declaration. If there is a global variable of that name, then
(with-ir1-environment-from-node node
(with-component-last-block (*current-component*
(block-next (component-head *current-component*)))
- (let* ((start (make-continuation))
- (block (continuation-starts-block start))
- (cont (make-continuation))
+ (let* ((start (make-ctran))
+ (block (ctran-starts-block start))
+ (next (make-ctran))
(*lexenv* (if cleanup
(make-lexenv :cleanup cleanup)
*lexenv*)))
(change-block-successor block1 block2 block)
(link-blocks block block2)
- (ir1-convert start cont form)
- (setf (block-last block) (continuation-use cont))
+ (ir1-convert start next nil form)
+ (setf (block-last block) (ctran-use next))
+ (setf (node-next (block-last block)) nil)
block))))
\f
;;;; continuation use hacking
-;;; Return a list of all the nodes which use Cont.
-(declaim (ftype (sfunction (continuation) list) find-uses))
-(defun find-uses (cont)
- (ecase (continuation-kind cont)
- ((:block-start :deleted-block-start)
- (block-start-uses (continuation-block cont)))
- (:inside-block (list (continuation-use cont)))
- (:unused nil)
- (:deleted nil)))
-
-(defun principal-continuation-use (cont)
- (let ((use (continuation-use cont)))
+;;; Return a list of all the nodes which use LVAR.
+(declaim (ftype (sfunction (lvar) list) find-uses))
+(defun find-uses (lvar)
+ (let ((uses (lvar-uses lvar)))
+ (if (listp uses)
+ uses
+ (list uses))))
+
+(defun principal-lvar-use (lvar)
+ (let ((use (lvar-uses lvar)))
(if (cast-p use)
- (principal-continuation-use (cast-value use))
+ (principal-lvar-use (cast-value use))
use)))
;;; Update continuation use information so that NODE is no longer a
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
;;; has changed.
-(declaim (ftype (sfunction (node) (values)) delete-continuation-use))
-(defun delete-continuation-use (node)
- (let* ((cont (node-cont node))
- (block (continuation-block cont)))
- (ecase (continuation-kind cont)
- (:deleted)
- ((:block-start :deleted-block-start)
- (let ((uses (delete node (block-start-uses block))))
- (setf (block-start-uses block) uses)
- (setf (continuation-use cont)
- (if (cdr uses) nil (car uses)))))
- (:inside-block
- (setf (continuation-kind cont) :unused)
- (setf (continuation-block cont) nil)
- (setf (continuation-use cont) nil)
- (setf (continuation-next cont) nil)))
- (setf (node-cont node) nil))
+(declaim (ftype (sfunction (node) (values))
+ delete-lvar-use
+ %delete-lvar-use))
+;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
+;;; be given a new use.
+(defun %delete-lvar-use (node)
+ (let* ((lvar (node-lvar node)))
+ (when lvar
+ (if (listp (lvar-uses lvar))
+ (let ((new-uses (delq node (lvar-uses lvar))))
+ (setf (lvar-uses lvar)
+ (if (singleton-p new-uses)
+ (first new-uses)
+ new-uses)))
+ (setf (lvar-uses lvar) nil))
+ (setf (node-lvar node) nil)))
+ (values))
+;;; Delete NODE from its LVAR uses.
+(defun delete-lvar-use (node)
+ (let ((lvar (node-lvar node)))
+ (when lvar
+ (%delete-lvar-use node)
+ (if (null (lvar-uses lvar))
+ (binding* ((dest (lvar-dest lvar) :exit-if-null)
+ (() (not (node-deleted dest)) :exit-if-null)
+ (block (node-block dest)))
+ (mark-for-deletion block))
+ (reoptimize-lvar lvar))))
(values))
;;; Update continuation use information so that NODE uses CONT. If
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
;;; has changed.
-(declaim (ftype (sfunction (node continuation) (values)) add-continuation-use))
-(defun add-continuation-use (node cont)
- (aver (not (node-cont node)))
- (let ((block (continuation-block cont)))
- (ecase (continuation-kind cont)
- (:deleted)
- (:unused
- (aver (not block))
- (let ((block (node-block node)))
- (aver block)
- (setf (continuation-block cont) block))
- (setf (continuation-kind cont) :inside-block)
- (setf (continuation-use cont) node))
- ((:block-start :deleted-block-start)
- (let ((uses (cons node (block-start-uses block))))
- (setf (block-start-uses block) uses)
- (setf (continuation-use cont)
- (if (cdr uses) nil (car uses)))
- (let ((block (node-block node)))
- (unless (block-last block)
- (setf (block-last block) node)))))))
- (setf (node-cont node) cont)
+(declaim (ftype (sfunction (node (or lvar null)) (values)) add-lvar-use))
+(defun add-lvar-use (node lvar)
+ (aver (not (node-lvar node)))
+ (when lvar
+ (let ((uses (lvar-uses lvar)))
+ (setf (lvar-uses lvar)
+ (cond ((null uses)
+ node)
+ ((listp uses)
+ (cons node uses))
+ (t
+ (list node uses))))
+ (setf (node-lvar node) lvar)))
+
(values))
-;;; Return true if CONT is the NODE-CONT for NODE and CONT is
-;;; transferred to immediately after the evaluation of NODE.
-(defun immediately-used-p (cont node)
- (declare (type continuation cont) (type node node))
- (and (eq (node-cont node) cont)
- (not (eq (continuation-kind cont) :deleted))
- (eq (continuation-dest cont)
- (continuation-next cont))
- (let ((cblock (continuation-block cont))
- (nblock (node-block node)))
- (or (eq cblock nblock)
- (let ((succ (block-succ nblock)))
- (and (= (length succ) 1)
- (eq (first succ) cblock)))))))
+;;; Return true if LVAR destination is executed immediately after
+;;; NODE. Cleanups are ignored.
+(defun immediately-used-p (lvar node)
+ (declare (type lvar lvar) (type node node))
+ (aver (eq (node-lvar node) lvar))
+ (and (eq (lvar-dest lvar)
+ (acond ((node-next node)
+ (ctran-next it))
+ (t (let* ((block (node-block node))
+ (next-block (first (block-succ block))))
+ (block-start-node next-block)))))))
\f
;;;; continuation substitution
;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
-;;; NIL. When we are done, we call FLUSH-DEST on OLD to clear its DEST
-;;; and to note potential optimization opportunities.
-(defun substitute-continuation (new old)
- (declare (type continuation old new))
- (aver (not (continuation-dest new)))
- (let ((dest (continuation-dest old)))
+;;; NIL. We do not flush OLD's DEST.
+(defun substitute-lvar (new old)
+ (declare (type lvar old new))
+ (aver (not (lvar-dest new)))
+ (let ((dest (lvar-dest old)))
(etypecase dest
((or ref bind))
(cif (setf (if-test dest) new))
(setf (basic-combination-fun dest) new)
(setf (basic-combination-args dest)
(nsubst new old (basic-combination-args dest)))))
- (cast (setf (cast-value dest) new))
- (null))
+ (cast (setf (cast-value dest) new)))
- (when dest (flush-dest old))
- (setf (continuation-dest new) dest)
- (flush-continuation-externally-checkable-type new))
+ (setf (lvar-dest old) nil)
+ (setf (lvar-dest new) dest)
+ (flush-lvar-externally-checkable-type new))
(values))
;;; Replace all uses of OLD with uses of NEW, where NEW has an
-;;; arbitary number of uses. If NEW will end up with more than one
-;;; use, then we must arrange for it to start a block if it doesn't
-;;; already.
-(defun substitute-continuation-uses (new old)
- (declare (type continuation old new))
- (unless (and (eq (continuation-kind new) :unused)
- (eq (continuation-kind old) :inside-block))
- (ensure-block-start new))
+;;; arbitary number of uses.
+(defun substitute-lvar-uses (new old)
+ (declare (type lvar old)
+ (type (or lvar null) new))
(do-uses (node old)
- (delete-continuation-use node)
- (add-continuation-use node new))
- (dolist (lexenv-use (continuation-lexenv-uses old)) ; FIXME - APD
- (setf (cadr lexenv-use) new))
+ (%delete-lvar-use node)
+ (when new
+ (add-lvar-use node new)))
- (reoptimize-continuation new)
+ (when new (reoptimize-lvar new))
(values))
\f
;;;; block starting/creation
-;;; Return the block that CONT is the start of, making a block if
+;;; Return the block that CTRAN is the start of, making a block if
;;; necessary. This function is called by IR1 translators which may
-;;; cause a continuation to be used more than once. Every continuation
-;;; which may be used more than once must start a block by the time
-;;; that anyone does a USE-CONTINUATION on it.
+;;; cause a CTRAN to be used more than once. Every CTRAN which may be
+;;; used more than once must start a block by the time that anyone
+;;; does a USE-CTRAN on it.
;;;
;;; We also throw the block into the next/prev list for the
;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
;;; made.
-(defun continuation-starts-block (cont)
- (declare (type continuation cont))
- (ecase (continuation-kind cont)
+(defun ctran-starts-block (ctran)
+ (declare (type ctran ctran))
+ (ecase (ctran-kind ctran)
(:unused
- (aver (not (continuation-block cont)))
+ (aver (not (ctran-block ctran)))
(let* ((next (component-last-block *current-component*))
(prev (block-prev next))
- (new-block (make-block cont)))
+ (new-block (make-block ctran)))
(setf (block-next new-block) next
(block-prev new-block) prev
(block-prev next) new-block
(block-next prev) new-block
- (continuation-block cont) new-block
- (continuation-use cont) nil
- (continuation-kind cont) :block-start)
+ (ctran-block ctran) new-block
+ (ctran-kind ctran) :block-start)
+ (aver (not (ctran-use ctran)))
new-block))
(:block-start
- (continuation-block cont))))
-
-;;; Ensure that CONT is the start of a block (or deleted) so that
-;;; the use set can be freely manipulated.
-;;; -- If the continuation is :UNUSED or is :INSIDE-BLOCK and the
-;;; CONT of LAST in its block, then we make it the start of a new
-;;; deleted block.
-;;; -- If the continuation is :INSIDE-BLOCK inside a block, then we
-;;; split the block using NODE-ENDS-BLOCK, which makes the
-;;; continuation be a :BLOCK-START.
-(defun ensure-block-start (cont)
- (declare (type continuation cont))
- (let ((kind (continuation-kind cont)))
+ (ctran-block ctran))))
+
+;;; Ensure that CTRAN is the start of a block so that the use set can
+;;; be freely manipulated.
+(defun ensure-block-start (ctran)
+ (declare (type ctran ctran))
+ (let ((kind (ctran-kind ctran)))
(ecase kind
- ((:deleted :block-start :deleted-block-start))
- ((:unused :inside-block)
- (let ((block (continuation-block cont)))
- (cond ((or (eq kind :unused)
- (eq (node-cont (block-last block)) cont))
- (setf (continuation-block cont)
- (make-block-key :start cont
- :component nil
- :start-uses (find-uses cont)))
- (setf (continuation-kind cont) :deleted-block-start))
- (t
- (node-ends-block (continuation-use cont))))))))
+ ((:block-start))
+ ((:unused)
+ (setf (ctran-block ctran)
+ (make-block-key :start ctran))
+ (setf (ctran-kind ctran) :block-start))
+ ((:inside-block)
+ (node-ends-block (ctran-use ctran)))))
(values))
\f
;;;;
-;;; Filter values of CONT with a destination through FORM, which must
-;;; be an ordinary/mv call. First argument must be 'DUMMY, which will
-;;; be replaced with CONT. In case of an ordinary call the function
-;;; should not have return type NIL.
+;;; Filter values of LVAR through FORM, which must be an ordinary/mv
+;;; call. First argument must be 'DUMMY, which will be replaced with
+;;; LVAR. In case of an ordinary call the function should not have
+;;; return type NIL. We create a new "filtered" lvar.
;;;
;;; TODO: remove preconditions.
-(defun filter-continuation (cont form)
- (declare (type continuation cont) (type list form))
- (let ((dest (continuation-dest cont)))
- (declare (type node dest))
+(defun filter-lvar (lvar form)
+ (declare (type lvar lvar) (type list form))
+ (let* ((dest (lvar-dest lvar))
+ (ctran (node-prev dest)))
(with-ir1-environment-from-node dest
- ;; Ensuring that CONT starts a block lets us freely manipulate its uses.
- (ensure-block-start cont)
-
- ;; Make a new continuation and move CONT's uses to it.
- (let ((new-start (make-continuation))
- (prev (node-prev dest)))
- (continuation-starts-block new-start)
- (substitute-continuation-uses new-start cont)
-
- ;; Make the DEST node start its block so that we can splice in
- ;; the LAMBDA code.
- (when (continuation-use prev)
- (node-ends-block (continuation-use prev)))
-
- (let* ((prev-block (continuation-block prev))
- (new-block (continuation-block new-start))
- (dummy (make-continuation)))
-
- ;; Splice in the new block before DEST, giving the new block
- ;; all of DEST's predecessors.
- (dolist (block (block-pred prev-block))
- (change-block-successor block prev-block new-block))
-
- ;; Convert the lambda form, using the new block start as
- ;; START and a dummy continuation as CONT.
- (ir1-convert new-start dummy form)
-
- ;; TODO: Why should this be true? -- WHN 19990601
- ;;
- ;; It is somehow related to the precondition of non-NIL
- ;; return type of the function. -- APD 2003-3-24
- (aver (eq (continuation-block dummy) new-block))
-
- ;; KLUDGE: Comments at the head of this function in CMU CL
- ;; said that somewhere in here we
- ;; Set the new block's start and end cleanups to the *start*
- ;; cleanup of PREV's block. This overrides the incorrect
- ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
- ;; Unfortunately I can't find any code which corresponds to this.
- ;; Perhaps it was a stale comment? Or perhaps I just don't
- ;; understand.. -- WHN 19990521
-
- (let ((node (continuation-use dummy)))
- (setf (block-last new-block) node)
- ;; Change the use to a use of CONT. (We need to use the
- ;; dummy continuation to get the control transfer right,
- ;; because we want to go to PREV's block, not CONT's.)
- (delete-continuation-use node)
- (add-continuation-use node cont))
- ;; Link the new block to PREV's block.
- (link-blocks new-block prev-block))
-
- ;; Replace 'DUMMY with the new continuation. (We can find
- ;; 'DUMMY because no LET conversion has been done yet.) The
- ;; [mv-]combination code from the call in the form will be the
- ;; use of the new check continuation. We substitute for the
- ;; first argument of this node.
- (let* ((node (continuation-use cont))
+ (ensure-block-start ctran)
+ (let* ((old-block (ctran-block ctran))
+ (new-start (make-ctran))
+ (filtered-lvar (make-lvar))
+ (new-block (ctran-starts-block new-start)))
+
+ ;; Splice in the new block before DEST, giving the new block
+ ;; all of DEST's predecessors.
+ (dolist (block (block-pred old-block))
+ (change-block-successor block old-block new-block))
+
+ (ir1-convert new-start ctran filtered-lvar form)
+
+ ;; KLUDGE: Comments at the head of this function in CMU CL
+ ;; said that somewhere in here we
+ ;; Set the new block's start and end cleanups to the *start*
+ ;; cleanup of PREV's block. This overrides the incorrect
+ ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
+ ;; Unfortunately I can't find any code which corresponds to this.
+ ;; Perhaps it was a stale comment? Or perhaps I just don't
+ ;; understand.. -- WHN 19990521
+
+ ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because
+ ;; no LET conversion has been done yet.) The [mv-]combination
+ ;; code from the call in the form will be the use of the new
+ ;; check lvar. We substitute for the first argument of
+ ;; this node.
+ (let* ((node (lvar-use filtered-lvar))
(args (basic-combination-args node))
(victim (first args)))
- (aver (eq (constant-value (ref-leaf (continuation-use victim)))
+ (aver (eq (constant-value (ref-leaf (lvar-use victim)))
'dummy))
- (substitute-continuation new-start victim)))
-
- ;; Invoking local call analysis converts this call to a LET.
- (locall-analyze-component *current-component*)
-
- (values))))
-
-;;; Deleting a filter may result in some calls becoming tail.
-(defun delete-filter (node cont value)
- (collect ((merges))
- (prog2
- (when (return-p (continuation-dest cont))
- (do-uses (use value)
- (when (and (basic-combination-p use)
- (eq (basic-combination-kind use) :local))
- (merges use))))
- (cond ((and (eq (continuation-kind cont) :inside-block)
- (eq (continuation-kind value) :inside-block))
- (setf (continuation-dest value) nil)
- (substitute-continuation value cont)
- (prog1 (unlink-node node)
- (setq cont value)))
- (t (ensure-block-start value)
- (ensure-block-start cont)
- (substitute-continuation-uses cont value)
- (prog1 (unlink-node node)
- (setf (continuation-dest value) nil))))
- (dolist (merge (merges))
- (merge-tail-sets merge)))))
+
+ (substitute-lvar filtered-lvar lvar)
+ (substitute-lvar lvar victim)
+ (flush-dest victim))
+
+ ;; Invoking local call analysis converts this call to a LET.
+ (locall-analyze-component *current-component*))))
+ (values))
+
+;;; Delete NODE and VALUE. It may result in some calls becoming tail.
+(defun delete-filter (node lvar value)
+ (aver (eq (lvar-dest value) node))
+ (aver (eq (node-lvar node) lvar))
+ (cond (lvar (collect ((merges))
+ (when (return-p (lvar-dest lvar))
+ (do-uses (use value)
+ (when (and (basic-combination-p use)
+ (eq (basic-combination-kind use) :local))
+ (merges use))))
+ (%delete-lvar-use node)
+ (substitute-lvar-uses lvar value)
+ (prog1
+ (unlink-node node)
+ (dolist (merge (merges))
+ (merge-tail-sets merge)))))
+ (t (flush-dest value)
+ (unlink-node node))))
\f
;;;; miscellaneous shorthand functions
(when (eq (lambda-home fun) fun)
(return fun))))
-(declaim (ftype (sfunction (node) cblock) node-block))
+#!-sb-fluid (declaim (inline node-block))
(defun node-block (node)
- (continuation-block (node-prev node)))
+ (ctran-block (node-prev node)))
(declaim (ftype (sfunction (node) component) node-component))
(defun node-component (node)
(block-component (node-block node)))
(declaim (ftype (sfunction (node) physenv) node-physenv))
(defun node-physenv (node)
(lambda-physenv (node-home-lambda node)))
+#!-sb-fluid (declaim (inline node-dest))
+(defun node-dest (node)
+ (awhen (node-lvar node) (lvar-dest it)))
(declaim (ftype (sfunction (clambda) cblock) lambda-block))
(defun lambda-block (clambda)
(defun lambda-component (clambda)
(block-component (lambda-block clambda)))
+(declaim (ftype (sfunction (cblock) node) block-start-node))
+(defun block-start-node (block)
+ (ctran-next (block-start block)))
+
;;; Return the enclosing cleanup for environment of the first or last
;;; node in BLOCK.
(defun block-start-cleanup (block)
- (declare (type cblock block))
- (node-enclosing-cleanup (continuation-next (block-start block))))
+ (node-enclosing-cleanup (block-start-node block)))
(defun block-end-cleanup (block)
- (declare (type cblock block))
(node-enclosing-cleanup (block-last block)))
;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
;;; Return NODE-SOURCE-FORM, T if continuation has a single use,
;;; otherwise NIL, NIL.
-(defun continuation-source (cont)
- (let ((use (continuation-use cont)))
- (if use
- (values (node-source-form use) t)
- (values nil nil))))
-
-;;; Return the LAMBDA that is CONT's home, or NIL if there is none.
-(declaim (ftype (sfunction (continuation) (or clambda null))
- continuation-home-lambda-or-null))
-(defun continuation-home-lambda-or-null (cont)
+(defun lvar-source (lvar)
+ (let ((use (lvar-uses lvar)))
+ (if (listp use)
+ (values nil nil)
+ (values (node-source-form use) t))))
+
+;;; Return the unique node, delivering a value to LVAR.
+#!-sb-fluid (declaim (inline lvar-use))
+(defun lvar-use (lvar)
+ (the (not list) (lvar-uses lvar)))
+
+#!-sb-fluid (declaim (inline lvar-has-single-use-p))
+(defun lvar-has-single-use-p (lvar)
+ (typep (lvar-uses lvar) '(not list)))
+
+;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none.
+(declaim (ftype (sfunction (ctran) (or clambda null))
+ ctran-home-lambda-or-null))
+(defun ctran-home-lambda-or-null (ctran)
;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
;; implementation might not be quite right, or might be uglier than
;; necessary. It appears that the original Python never found a need
;; to do this operation. The obvious things based on
- ;; NODE-HOME-LAMBDA of CONTINUATION-USE usually work; then if that
- ;; fails, BLOCK-HOME-LAMBDA of CONTINUATION-BLOCK works, given that
- ;; we generalize it enough to grovel harder when the simple CMU CL
+ ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails,
+ ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we
+ ;; generalize it enough to grovel harder when the simple CMU CL
;; approach fails, and furthermore realize that in some exceptional
;; cases it might return NIL. -- WHN 2001-12-04
- (cond ((continuation-use cont)
- (node-home-lambda (continuation-use cont)))
- ((continuation-block cont)
- (block-home-lambda-or-null (continuation-block cont)))
+ (cond ((ctran-use ctran)
+ (node-home-lambda (ctran-use ctran)))
+ ((ctran-block ctran)
+ (block-home-lambda-or-null (ctran-block ctran)))
(t
- (bug "confused about home lambda for ~S" cont))))
-
-;;; Return the LAMBDA that is CONT's home.
-(declaim (ftype (sfunction (continuation) clambda)
- continuation-home-lambda))
-(defun continuation-home-lambda (cont)
- (continuation-home-lambda-or-null cont))
-
-#!-sb-fluid (declaim (inline continuation-single-value-p))
-(defun continuation-single-value-p (cont)
- (let ((dest (continuation-dest cont)))
- (typecase dest
- ((or creturn exit)
- nil)
- (mv-combination
- (eq (basic-combination-fun dest) cont))
- (cast
- (locally
- (declare (notinline continuation-single-value-p))
- (and (not (values-type-p (cast-asserted-type dest)))
- (continuation-single-value-p (node-cont dest)))))
- (t
- t))))
-
-(defun principal-continuation-end (cont)
- (loop for prev = cont then (node-cont dest)
- for dest = (continuation-dest prev)
+ (bug "confused about home lambda for ~S" ctran))))
+
+;;; Return the LAMBDA that is CTRAN's home.
+(declaim (ftype (sfunction (ctran) clambda) ctran-home-lambda))
+(defun ctran-home-lambda (ctran)
+ (ctran-home-lambda-or-null ctran))
+
+#!-sb-fluid (declaim (inline lvar-single-value-p))
+(defun lvar-single-value-p (lvar)
+ (or (not lvar)
+ (let ((dest (lvar-dest lvar)))
+ (typecase dest
+ ((or creturn exit)
+ nil)
+ (mv-combination
+ (eq (basic-combination-fun dest) lvar))
+ (cast
+ (locally
+ (declare (notinline lvar-single-value-p))
+ (and (not (values-type-p (cast-asserted-type dest)))
+ (lvar-single-value-p (node-lvar dest)))))
+ (t
+ t)))))
+
+(defun principal-lvar-end (lvar)
+ (loop for prev = lvar then (node-lvar dest)
+ for dest = (and prev (lvar-dest prev))
while (cast-p dest)
finally (return (values dest prev))))
-(defun principal-continuation-single-valuify (cont)
- (loop for prev = cont then (node-cont dest)
- for dest = (continuation-dest prev)
- while (cast-p dest)
- do (setf (node-derived-type dest)
- (make-short-values-type (list (single-value-type
- (node-derived-type dest)))))
- (reoptimize-continuation prev)))
+(defun principal-lvar-single-valuify (lvar)
+ (loop for prev = lvar then (node-lvar dest)
+ for dest = (and prev (lvar-dest prev))
+ while (cast-p dest)
+ do (setf (node-derived-type dest)
+ (make-short-values-type (list (single-value-type
+ (node-derived-type dest)))))
+ (reoptimize-lvar prev)))
\f
;;; Return a new LEXENV just like DEFAULT except for the specified
;;; slot values. Values for the alist slots are NCONCed to the
(push block1 (block-pred block2))
(values))
(defun %link-blocks (block1 block2)
- (declare (type cblock block1 block2) (inline member))
+ (declare (type cblock block1 block2))
(let ((succ1 (block-succ block1)))
- (aver (not (member block2 succ1 :test #'eq)))
+ (aver (not (memq block2 succ1)))
(cons block2 succ1)))
;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If
;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to
;;; the new successor.
(defun change-block-successor (block old new)
- (declare (type cblock new old block) (inline member))
+ (declare (type cblock new old block))
(unlink-blocks block old)
(let ((last (block-last block))
(comp (block-component block)))
succ-left)
(first succ-left)
new)))
- (unless (member new succ-left :test #'eq)
+ (unless (memq new succ-left)
(link-blocks block new))
(macrolet ((frob (slot)
`(when (eq (,slot last) old)
(if-alternative last))
(setf (component-reoptimize (block-component block)) t)))))
(t
- (unless (member new (block-succ block) :test #'eq)
+ (unless (memq new (block-succ block))
(link-blocks block new)))))
(values))
(defun node-ends-block (node)
(declare (type node node))
(let* ((block (node-block node))
- (start (node-cont node))
- (last (block-last block))
- (last-cont (node-cont last)))
+ (start (node-next node))
+ (last (block-last block)))
(unless (eq last node)
- (aver (and (eq (continuation-kind start) :inside-block)
- (not (block-delete-p block))))
+ (aver (and (eq (ctran-kind start) :inside-block)
+ (not (block-delete-p block))))
(let* ((succ (block-succ block))
(new-block
(make-block-key :start start
:component (block-component block)
- :start-uses (list (continuation-use start))
:succ succ :last last)))
- (setf (continuation-kind start) :block-start)
+ (setf (ctran-kind start) :block-start)
+ (setf (ctran-use start) nil)
+ (setf (block-last block) node)
+ (setf (node-next node) nil)
(dolist (b succ)
(setf (block-pred b)
(cons new-block (remove block (block-pred b)))))
(setf (block-succ block) ())
- (setf (block-last block) node)
(link-blocks block new-block)
(add-to-dfo new-block block)
(setf (component-reanalyze (block-component block)) t)
- (do ((cont start (node-cont (continuation-next cont))))
- ((eq cont last-cont)
- (when (eq (continuation-kind last-cont) :inside-block)
- (setf (continuation-block last-cont) new-block)))
- (setf (continuation-block cont) new-block))
+ (do ((ctran start (node-next (ctran-next ctran))))
+ ((not ctran))
+ (setf (ctran-block ctran) new-block))
(setf (block-type-asserted block) t)
(setf (block-test-modified block) t))))
-
(values))
\f
;;;; deleting stuff
(let* ((fun (lambda-var-home leaf))
(n (position leaf (lambda-vars fun))))
(dolist (ref (leaf-refs fun))
- (let* ((cont (node-cont ref))
- (dest (continuation-dest cont)))
+ (let* ((lvar (node-lvar ref))
+ (dest (and lvar (lvar-dest lvar))))
(when (and (combination-p dest)
- (eq (basic-combination-fun dest) cont)
+ (eq (basic-combination-fun dest) lvar)
(eq (basic-combination-kind dest) :local))
(let* ((args (basic-combination-args dest))
(arg (elt args n)))
- (reoptimize-continuation arg)
+ (reoptimize-lvar arg)
(flush-dest arg)
(setf (elt args n) nil))))))
(when (and (eq (functional-kind fun) :let)
(leaf-refs var))
(do ((args (basic-combination-args
- (continuation-dest
- (node-cont
- (first (leaf-refs fun)))))
+ (lvar-dest (node-lvar (first (leaf-refs fun)))))
(cdr args))
(vars (lambda-vars fun) (cdr vars)))
((eq (car vars) var)
- (reoptimize-continuation (car args))))))
+ (reoptimize-lvar (car args))))))
(values))
;;; Delete a function that has no references. This need only be called
(defun delete-ref (ref)
(declare (type ref ref))
(let* ((leaf (ref-leaf ref))
- (refs (delete ref (leaf-refs leaf))))
+ (refs (delq ref (leaf-refs leaf))))
(setf (leaf-refs leaf) refs)
(cond ((null refs)
(values))
;;; This function is called by people who delete nodes; it provides a
-;;; way to indicate that the value of a continuation is no longer
-;;; used. We null out the CONTINUATION-DEST, set FLUSH-P in the blocks
-;;; containing uses of CONT and set COMPONENT-REOPTIMIZE. If the PREV
-;;; of the use is deleted, then we blow off reoptimization.
-;;;
-;;; If the continuation is :DELETED, then we don't do anything, since
-;;; all semantics have already been flushed. :DELETED-BLOCK-START
-;;; start continuations are treated just like :BLOCK-START; it is
-;;; possible that the continuation may be given a new dest (e.g. by
-;;; SUBSTITUTE-CONTINUATION), so we don't want to delete it.
-(defun flush-dest (cont)
- (declare (type continuation cont))
-
- (unless (eq (continuation-kind cont) :deleted)
- (aver (continuation-dest cont))
- (setf (continuation-dest cont) nil)
- (flush-continuation-externally-checkable-type cont)
- (do-uses (use cont)
+;;; way to indicate that the value of a lvar is no longer used. We
+;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
+;;; of LVAR and set COMPONENT-REOPTIMIZE.
+(defun flush-dest (lvar)
+ (declare (type (or lvar null) lvar))
+ (unless (null lvar)
+ (setf (lvar-dest lvar) nil)
+ (flush-lvar-externally-checkable-type lvar)
+ (do-uses (use lvar)
(let ((prev (node-prev use)))
- (unless (eq (continuation-kind prev) :deleted)
- (let ((block (continuation-block prev)))
- (setf (component-reoptimize (block-component block)) t)
- (setf (block-attributep (block-flags block) flush-p type-asserted)
- t))))))
-
+ (let ((block (ctran-block prev)))
+ (setf (component-reoptimize (block-component block)) t)
+ (setf (block-attributep (block-flags block) flush-p type-asserted)
+ t)))
+ (setf (node-lvar use) nil))
+ (setf (lvar-uses lvar) nil))
(values))
-(defun delete-dest (cont)
- (let ((dest (continuation-dest cont)))
- (when dest
- (let ((prev (node-prev dest)))
- (when (and prev
- (not (eq (continuation-kind prev) :deleted)))
- (let ((block (continuation-block prev)))
- (unless (block-delete-p block)
- (mark-for-deletion block))))))))
+(defun delete-dest (lvar)
+ (when lvar
+ (let* ((dest (lvar-dest lvar))
+ (prev (node-prev dest)))
+ (let ((block (ctran-block prev)))
+ (unless (block-delete-p block)
+ (mark-for-deletion block))))))
;;; Do a graph walk backward from BLOCK, marking all predecessor
;;; blocks with the DELETE-P flag.
(setf (component-reanalyze component) t))))
(values))
-;;; Delete CONT, eliminating both control and value semantics. We set
-;;; FLUSH-P and COMPONENT-REOPTIMIZE similarly to in FLUSH-DEST. Here
-;;; we must get the component from the use block, since the
-;;; continuation may be a :DELETED-BLOCK-START.
-;;;
-;;; If CONT has DEST, then it must be the case that the DEST is
-;;; unreachable, since we can't compute the value desired. In this
-;;; case, we call MARK-FOR-DELETION to cause the DEST block and its
-;;; predecessors to tell people to ignore them, and to cause them to
-;;; be deleted eventually.
-(defun delete-continuation (cont)
- (declare (type continuation cont))
- (aver (not (eq (continuation-kind cont) :deleted)))
-
- (do-uses (use cont)
- (let ((prev (node-prev use)))
- (unless (eq (continuation-kind prev) :deleted)
- (let ((block (continuation-block prev)))
- (setf (block-attributep (block-flags block) flush-p type-asserted) t)
- (setf (component-reoptimize (block-component block)) t)))))
-
- (delete-dest cont)
-
- (setf (continuation-kind cont) :deleted)
- (setf (continuation-dest cont) nil)
- (flush-continuation-externally-checkable-type cont)
- (setf (continuation-next cont) nil)
- (setf (continuation-%derived-type cont) *empty-type*)
- (setf (continuation-use cont) nil)
- (setf (continuation-block cont) nil)
- (setf (continuation-reoptimize cont) nil)
- (setf (continuation-info cont) nil)
-
- (values))
-
;;; This function does what is necessary to eliminate the code in it
;;; from the IR1 representation. This involves unlinking it from its
;;; predecessors and successors and deleting various node-specific
;;; semantic information.
-;;;
-;;; We mark the START as has having no next and remove the last node
-;;; from its CONT's uses. We also flush the DEST for all continuations
-;;; whose values are received by nodes in the block.
(defun delete-block (block &optional silent)
(declare (type cblock block))
(aver (block-component block)) ; else block is already deleted!
(note-block-deletion block))
(setf (block-delete-p block) t)
- (let ((last (block-last block)))
- (when last
- (let ((cont (node-cont last)))
- (delete-continuation-use last)
- (acond ((eq (continuation-kind cont) :unused)
- (delete-continuation cont))
- ((and (null (find-uses cont))
- (continuation-dest cont))
- (mark-for-deletion (node-block it)))
- ((reoptimize-continuation cont))))))
-
(dolist (b (block-pred block))
(unlink-blocks b block)
;; In bug 147 the almost-all-blocks-have-a-successor invariant was
(dolist (b (block-succ block))
(unlink-blocks block b))
- (do-nodes-carefully (node cont block)
+ (do-nodes-carefully (node block)
+ (when (valued-node-p node)
+ (delete-lvar-use node))
(typecase node
(ref (delete-ref node))
- (cif
- (flush-dest (if-test node)))
+ (cif (flush-dest (if-test node)))
;; The next two cases serve to maintain the invariant that a LET
;; always has a well-formed COMBINATION, REF and BIND. We delete
;; the lambda whenever we delete any of these, but we must be
(basic-combination
(when (and (eq (basic-combination-kind node) :local)
;; Guards COMBINATION-LAMBDA agains the REF being deleted.
- (continuation-use (basic-combination-fun node)))
+ (lvar-uses (basic-combination-fun node)))
(let ((fun (combination-lambda node)))
;; If our REF was the second-to-last ref, and has been
;; deleted, then FUN may be a LET for some other
(flush-dest value))
(when entry
(setf (entry-exits entry)
- (delete node (entry-exits entry))))))
+ (delq node (entry-exits entry))))))
(creturn
(flush-dest (return-result node))
(delete-return node))
(setf (basic-var-sets var)
(delete node (basic-var-sets var)))))
(cast
- (flush-dest (cast-value node))))
-
- (delete-continuation (node-prev node)))
+ (flush-dest (cast-value node)))))
(remove-from-dfo block)
(values))
(defun note-block-deletion (block)
(let ((home (block-home-lambda block)))
(unless (eq (functional-kind home) :deleted)
- (do-nodes (node cont block)
+ (do-nodes (node nil block)
(let* ((path (node-source-path node))
(first (first path)))
(when (or (eq first 'original-source-start)
(values))
;;; Delete a node from a block, deleting the block if there are no
-;;; nodes left. We remove the node from the uses of its CONT, but we
-;;; don't deal with cleaning up any type-specific semantic
-;;; attachments. If the CONT is :UNUSED after deleting this use, then
-;;; we delete CONT. (Note :UNUSED is not the same as no uses. A
-;;; continuation will only become :UNUSED if it was :INSIDE-BLOCK
-;;; before.)
+;;; nodes left. We remove the node from the uses of its LVAR.
;;;
;;; If the node is the last node, there must be exactly one successor.
;;; We link all of our precedessors to the successor and unlink the
;;; empty blocks in IR1.
(defun unlink-node (node)
(declare (type node node))
- (let* ((cont (node-cont node))
- (next (continuation-next cont))
+ (when (valued-node-p node)
+ (delete-lvar-use node))
+
+ (let* ((ctran (node-next node))
+ (next (and ctran (ctran-next ctran)))
(prev (node-prev node))
- (block (continuation-block prev))
- (prev-kind (continuation-kind prev))
+ (block (ctran-block prev))
+ (prev-kind (ctran-kind prev))
(last (block-last block)))
- (unless (eq (continuation-kind cont) :deleted)
- (delete-continuation-use node)
- (when (eq (continuation-kind cont) :unused)
- (aver (not (continuation-dest cont)))
- (delete-continuation cont)))
-
(setf (block-type-asserted block) t)
(setf (block-test-modified block) t)
(and (eq prev-kind :block-start)
(not (eq node last))))
(cond ((eq node last)
- (setf (block-last block) (continuation-use prev))
- (setf (continuation-next prev) nil))
+ (setf (block-last block) (ctran-use prev))
+ (setf (node-next (ctran-use prev)) nil))
(t
- (setf (continuation-next prev) next)
+ (setf (ctran-next prev) next)
(setf (node-prev next) prev)
- (when (and (if-p next) ; AOP wanted
- (eq prev (if-test next)))
- (reoptimize-continuation prev))))
+ (when (if-p next) ; AOP wanted
+ (reoptimize-lvar (if-test next)))))
(setf (node-prev node) nil)
nil)
(t
(next (first succ)))
(aver (singleton-p succ))
(cond
- ((member block succ)
+ ((eq block (first succ))
(with-ir1-environment-from-node node
- (let ((exit (make-exit))
- (dummy (make-continuation)))
- (setf (continuation-next prev) nil)
- (link-node-to-previous-continuation exit prev)
- (add-continuation-use exit dummy)
+ (let ((exit (make-exit)))
+ (setf (ctran-next prev) nil)
+ (link-node-to-previous-ctran exit prev)
(setf (block-last block) exit)))
(setf (node-prev node) nil)
nil)
(dolist (pred (block-pred block))
(change-block-successor pred block next))
(remove-from-dfo block)
- (cond ((continuation-dest prev)
- (setf (continuation-next prev) nil)
- (setf (continuation-kind prev) :deleted-block-start))
- (t
- (delete-continuation prev)))
+ (setf (block-delete-p block) t)
(setf (node-prev node) nil)
t)))))))
(declare (type node node))
(let ((prev (node-prev node)))
(not (and prev
- (not (eq (continuation-kind prev) :deleted))
- (let ((block (continuation-block prev)))
+ (let ((block (ctran-block prev)))
(and (block-component block)
(not (block-delete-p block))))))))
;;; of arguments changes, the transform must be prepared to return a
;;; lambda with a new lambda-list with the correct number of
;;; arguments.
-(defun extract-fun-args (cont fun num-args)
+(defun extract-fun-args (lvar fun num-args)
#!+sb-doc
"If CONT is a call to FUN with NUM-ARGS args, change those arguments
- to feed directly to the continuation-dest of CONT, which must be
- a combination."
- (declare (type continuation cont)
+ to feed directly to the LVAR-DEST of LVAR, which must be a
+ combination."
+ (declare (type lvar lvar)
(type symbol fun)
(type index num-args))
- (let ((outside (continuation-dest cont))
- (inside (continuation-use cont)))
+ (let ((outside (lvar-dest lvar))
+ (inside (lvar-uses lvar)))
(aver (combination-p outside))
(unless (combination-p inside)
(give-up-ir1-transform))
(let ((inside-fun (combination-fun inside)))
- (unless (eq (continuation-fun-name inside-fun) fun)
+ (unless (eq (lvar-fun-name inside-fun) fun)
(give-up-ir1-transform))
(let ((inside-args (combination-args inside)))
(unless (= (length inside-args) num-args)
(give-up-ir1-transform))
(let* ((outside-args (combination-args outside))
- (arg-position (position cont outside-args))
+ (arg-position (position lvar outside-args))
(before-args (subseq outside-args 0 arg-position))
(after-args (subseq outside-args (1+ arg-position))))
(dolist (arg inside-args)
- (setf (continuation-dest arg) outside)
- (flush-continuation-externally-checkable-type arg))
+ (setf (lvar-dest arg) outside)
+ (flush-lvar-externally-checkable-type arg))
(setf (combination-args inside) nil)
(setf (combination-args outside)
(append before-args inside-args after-args))
- (change-ref-leaf (continuation-use inside-fun)
+ (change-ref-leaf (lvar-uses inside-fun)
(find-free-fun 'list "???"))
(setf (combination-kind inside)
(info :function :info 'list))
(setf (node-derived-type inside) *wild-type*)
- (flush-dest cont)
+ (flush-dest lvar)
(values))))))
(defun flush-combination (combination)
(setf (leaf-ever-used leaf) t)
(let* ((ltype (leaf-type leaf))
(vltype (make-single-value-type ltype)))
- (if (let* ((cont (node-cont ref))
- (dest (continuation-dest cont)))
+ (if (let* ((lvar (node-lvar ref))
+ (dest (and lvar (lvar-dest lvar))))
(and (basic-combination-p dest)
- (eq cont (basic-combination-fun dest))
+ (eq lvar (basic-combination-fun dest))
(csubtypep ltype (specifier-type 'function))))
(setf (node-derived-type ref) vltype)
(derive-node-type ref vltype)))
- (reoptimize-continuation (node-cont ref)))
+ (reoptimize-lvar (node-lvar ref)))
(values))
;;; Change all REFS for OLD-LEAF to NEW-LEAF.
nil)
(t (let ((home (lambda-home home)))
(flet ((frob (l)
- (find home l :key #'node-home-lambda
+ (find home l
+ :key #'node-home-lambda
:test-not #'eq)))
(or (frob (leaf-refs var))
(frob (basic-var-sets var)))))))))
;;; If there is a non-local exit noted in ENTRY's environment that
;;; exits to CONT in that entry, then return it, otherwise return NIL.
-(defun find-nlx-info (entry cont)
- (declare (type entry entry) (type continuation cont))
- (let ((entry-cleanup (entry-cleanup entry)))
+(defun find-nlx-info (exit)
+ (declare (type exit exit))
+ (let* ((entry (exit-entry exit))
+ (entry-cleanup (entry-cleanup entry)))
(dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
- (when (and (eq (nlx-info-continuation nlx) cont)
- (eq (nlx-info-cleanup nlx) entry-cleanup))
+ (when (eq (nlx-info-exit nlx) exit)
(return nlx)))))
\f
;;;; functional hackery
(declare (type functional fun))
(not (null (member (functional-kind fun) '(:external :toplevel)))))
-;;; If CONT's only use is a non-notinline global function reference,
+;;; If LVAR's only use is a non-notinline global function reference,
;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
;;; is true, then we don't care if the leaf is NOTINLINE.
-(defun continuation-fun-name (cont &optional notinline-ok)
- (declare (type continuation cont))
- (let ((use (continuation-use cont)))
+(defun lvar-fun-name (lvar &optional notinline-ok)
+ (declare (type lvar lvar))
+ (let ((use (lvar-uses lvar)))
(if (ref-p use)
(let ((leaf (ref-leaf use)))
(if (and (global-var-p leaf)
;;; Return the source name of a combination. (This is an idiom
;;; which was used in CMU CL. I gather it always works. -- WHN)
(defun combination-fun-source-name (combination)
- (let ((ref (continuation-use (combination-fun combination))))
+ (let ((ref (lvar-uses (combination-fun combination))))
(leaf-source-name (ref-leaf ref))))
;;; Return the COMBINATION node that is the call to the LET FUN.
(defun let-combination (fun)
(declare (type clambda fun))
(aver (functional-letlike-p fun))
- (continuation-dest (node-cont (first (leaf-refs fun)))))
+ (lvar-dest (node-lvar (first (leaf-refs fun)))))
;;; Return the initial value continuation for a LET variable, or NIL
;;; if there is none.
(defun combination-lambda (call)
(declare (type basic-combination call))
(aver (eq (basic-combination-kind call) :local))
- (ref-leaf (continuation-use (basic-combination-fun call))))
+ (ref-leaf (lvar-uses (basic-combination-fun call))))
(defvar *inline-expansion-limit* 200
#!+sb-doc
;;;; utilities used at run-time for parsing &KEY args in IR1
;;; This function is used by the result of PARSE-DEFTRANSFORM to find
-;;; the continuation for the value of the &KEY argument KEY in the
-;;; list of continuations ARGS. It returns the continuation if the
-;;; keyword is present, or NIL otherwise. The legality and
-;;; constantness of the keywords should already have been checked.
-(declaim (ftype (sfunction (list keyword) (or continuation null))
- find-keyword-continuation))
-(defun find-keyword-continuation (args key)
+;;; the lvar for the value of the &KEY argument KEY in the list of
+;;; lvars ARGS. It returns the lvar if the keyword is present, or NIL
+;;; otherwise. The legality and constantness of the keywords should
+;;; already have been checked.
+(declaim (ftype (sfunction (list keyword) (or lvar null))
+ find-keyword-lvar))
+(defun find-keyword-lvar (args key)
(do ((arg args (cddr arg)))
((null arg) nil)
- (when (eq (continuation-value (first arg)) key)
+ (when (eq (lvar-value (first arg)) key)
(return (second arg)))))
;;; This function is used by the result of PARSE-DEFTRANSFORM to
-;;; verify that alternating continuations in ARGS are constant and
-;;; that there is an even number of args.
+;;; verify that alternating lvars in ARGS are constant and that there
+;;; is an even number of args.
(declaim (ftype (sfunction (list) boolean) check-key-args-constant))
(defun check-key-args-constant (args)
(do ((arg args (cddr arg)))
((null arg) t)
(unless (and (rest arg)
- (constant-continuation-p (first arg)))
+ (constant-lvar-p (first arg)))
(return nil))))
;;; This function is used by the result of PARSE-DEFTRANSFORM to
-;;; verify that the list of continuations ARGS is a well-formed &KEY
-;;; arglist and that only keywords present in the list KEYS are
-;;; supplied.
+;;; verify that the list of lvars ARGS is a well-formed &KEY arglist
+;;; and that only keywords present in the list KEYS are supplied.
(declaim (ftype (sfunction (list list) boolean) check-transform-keys))
(defun check-transform-keys (args keys)
(and (check-key-args-constant args)
(do ((arg args (cddr arg)))
((null arg) t)
- (unless (member (continuation-value (first arg)) keys)
+ (unless (member (lvar-value (first arg)) keys)
(return nil)))))
\f
;;;; miscellaneous
;;;
(defun make-cast (value type policy)
- (declare (type continuation value)
+ (declare (type lvar value)
(type ctype type)
(type policy policy))
(%make-cast :asserted-type type
(ir1-optimize-cast cast t))
(cast-%type-check cast))
-(defun note-single-valuified-continuation (cont)
- (declare (type continuation cont))
- (let ((use (continuation-use cont)))
- (cond ((ref-p use)
- (let ((leaf (ref-leaf use)))
- (when (and (lambda-var-p leaf)
- (null (rest (leaf-refs leaf))))
- (reoptimize-lambda-var leaf))))
- ((or (null use) (combination-p use))
- (dolist (node (find-uses cont))
- (setf (node-reoptimize node) t)
- (setf (block-reoptimize (node-block node)) t)
- (setf (component-reoptimize (node-component node)) t))))))
+(defun note-single-valuified-lvar (lvar)
+ (declare (type (or lvar null) lvar))
+ (when lvar
+ (let ((use (lvar-uses lvar)))
+ (cond ((ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (when (and (lambda-var-p leaf)
+ (null (rest (leaf-refs leaf))))
+ (reoptimize-lambda-var leaf))))
+ ((or (listp use) (combination-p use))
+ (do-uses (node lvar)
+ (setf (node-reoptimize node) t)
+ (setf (block-reoptimize (node-block node)) t)
+ (setf (component-reoptimize (node-component node)) t)))))))
;;; Convert a REF node. The reference must not be delayed.
(defun ir2-convert-ref (node block)
(declare (type ref node) (type ir2-block block))
- (let* ((cont (node-cont node))
+ (let* ((lvar (node-lvar node))
(leaf (ref-leaf node))
- (locs (continuation-result-tns
- cont (list (primitive-type (leaf-type leaf)))))
+ (locs (lvar-result-tns
+ lvar (list (primitive-type (leaf-type leaf)))))
(res (first locs)))
(etypecase leaf
(lambda-var
(if unsafe
(vop fdefn-fun node block fdefn-tn res)
(vop safe-fdefn-fun node block fdefn-tn res))))))))
- (move-continuation-result node block locs cont))
+ (move-lvar-result node block locs lvar))
(values))
;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE
;;; the variable has been deleted.
(defun ir2-convert-set (node block)
(declare (type cset node) (type ir2-block block))
- (let* ((cont (node-cont node))
+ (let* ((lvar (node-lvar node))
(leaf (set-var node))
- (val (continuation-tn node block (set-value node)))
- (locs (if (continuation-info cont)
- (continuation-result-tns
- cont (list (primitive-type (leaf-type leaf))))
+ (val (lvar-tn node block (set-value node)))
+ (locs (if lvar
+ (lvar-result-tns
+ lvar (list (primitive-type (leaf-type leaf))))
nil)))
(etypecase leaf
(lambda-var
(vop set node block (emit-constant (leaf-source-name leaf)) val)))))
(when locs
(emit-move node block val (first locs))
- (move-continuation-result node block locs cont)))
+ (move-lvar-result node block locs lvar)))
(values))
\f
;;;; utilities for receiving fixed values
;;; and move the actual continuation TN into it. This happens when we
;;; delete a type check in unsafe code or when we locally know
;;; something about the type of an argument variable.
-(defun continuation-tn (node block cont)
- (declare (type node node) (type ir2-block block) (type continuation cont))
- (let* ((2cont (continuation-info cont))
- (cont-tn
- (ecase (ir2-continuation-kind 2cont)
+(defun lvar-tn (node block lvar)
+ (declare (type node node) (type ir2-block block) (type lvar lvar))
+ (let* ((2lvar (lvar-info lvar))
+ (lvar-tn
+ (ecase (ir2-lvar-kind 2lvar)
(:delayed
- (let ((ref (continuation-use cont)))
+ (let ((ref (lvar-uses lvar)))
(leaf-tn (ref-leaf ref) (node-physenv ref))))
(:fixed
- (aver (= (length (ir2-continuation-locs 2cont)) 1))
- (first (ir2-continuation-locs 2cont)))))
- (ptype (ir2-continuation-primitive-type 2cont)))
+ (aver (= (length (ir2-lvar-locs 2lvar)) 1))
+ (first (ir2-lvar-locs 2lvar)))))
+ (ptype (ir2-lvar-primitive-type 2lvar)))
- (cond ((eq (tn-primitive-type cont-tn) ptype) cont-tn)
+ (cond ((eq (tn-primitive-type lvar-tn) ptype) lvar-tn)
(t
(let ((temp (make-normal-tn ptype)))
- (emit-move node block cont-tn temp)
+ (emit-move node block lvar-tn temp)
temp)))))
;;; This is similar to CONTINUATION-TN, but hacks multiple values. We
;;; If the continuation has a type check, check the values into temps
;;; and return the temps. When we have more values than assertions, we
;;; move the extra values with no check.
-(defun continuation-tns (node block cont ptypes)
+(defun lvar-tns (node block lvar ptypes)
(declare (type node node) (type ir2-block block)
- (type continuation cont) (list ptypes))
- (let* ((locs (ir2-continuation-locs (continuation-info cont)))
+ (type lvar lvar) (list ptypes))
+ (let* ((locs (ir2-lvar-locs (lvar-info lvar)))
(nlocs (length locs)))
(aver (= nlocs (length ptypes)))
;;; necessary by discarded TNs. We always return a TN of the specified
;;; type, using the continuation locs only when they are of the
;;; correct type.
-(defun continuation-result-tns (cont types)
- (declare (type continuation cont) (type list types))
- (let ((2cont (continuation-info cont)))
- (if (not 2cont)
- (mapcar #'make-normal-tn types)
- (ecase (ir2-continuation-kind 2cont)
+(defun lvar-result-tns (lvar types)
+ (declare (type (or lvar null) lvar) (type list types))
+ (if (not lvar)
+ (mapcar #'make-normal-tn types)
+ (let ((2lvar (lvar-info lvar)))
+ (ecase (ir2-lvar-kind 2lvar)
(:fixed
- (let* ((locs (ir2-continuation-locs 2cont))
+ (let* ((locs (ir2-lvar-locs 2lvar))
(nlocs (length locs))
(ntypes (length types)))
(if (and (= nlocs ntypes)
;;; returning an empty list of temporaries.
;;;
;;; If the continuation is annotated, then it must be :FIXED.
-(defun standard-result-tns (cont)
- (declare (type continuation cont))
- (let ((2cont (continuation-info cont)))
- (if 2cont
- (ecase (ir2-continuation-kind 2cont)
- (:fixed
- (make-standard-value-tns (length (ir2-continuation-locs 2cont)))))
- ())))
+(defun standard-result-tns (lvar)
+ (declare (type (or lvar null) lvar))
+ (if lvar
+ (let ((2lvar (lvar-info lvar)))
+ (ecase (ir2-lvar-kind 2lvar)
+ (:fixed
+ (make-standard-value-tns (length (ir2-lvar-locs 2lvar))))))
+ nil))
;;; Just move each SRC TN into the corresponding DEST TN, defaulting
;;; any unsupplied source values to NIL. We let EMIT-MOVE worry about
;;; the continuation locations. If the continuation is unknown values,
;;; then do the moves into the standard value locations, and use
;;; PUSH-VALUES to put the values on the stack.
-(defun move-continuation-result (node block results cont)
+(defun move-lvar-result (node block results lvar)
(declare (type node node) (type ir2-block block)
- (list results) (type continuation cont))
- (let* ((2cont (continuation-info cont)))
- (when 2cont
- (ecase (ir2-continuation-kind 2cont)
- (:fixed
- (let ((locs (ir2-continuation-locs 2cont)))
- (unless (eq locs results)
- (move-results-coerced node block results locs))))
- (:unknown
- (let* ((nvals (length results))
- (locs (make-standard-value-tns nvals)))
- (move-results-coerced node block results locs)
- (vop* push-values node block
- ((reference-tn-list locs nil))
- ((reference-tn-list (ir2-continuation-locs 2cont) t))
- nvals))))))
+ (list results) (type (or lvar null) lvar))
+ (when lvar
+ (let ((2lvar (lvar-info lvar)))
+ (ecase (ir2-lvar-kind 2lvar)
+ (:fixed
+ (let ((locs (ir2-lvar-locs 2lvar)))
+ (unless (eq locs results)
+ (move-results-coerced node block results locs))))
+ (:unknown
+ (let* ((nvals (length results))
+ (locs (make-standard-value-tns nvals)))
+ (move-results-coerced node block results locs)
+ (vop* push-values node block
+ ((reference-tn-list locs nil))
+ ((reference-tn-list (ir2-lvar-locs 2lvar) 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))
+ (binding* ((lvar (node-lvar node) :exit-if-null)
+ (2lvar (lvar-info lvar))
+ (value (cast-value node))
+ (2value (lvar-info value)))
+ (cond ((eq (ir2-lvar-kind 2lvar) :unused))
+ ((eq (ir2-lvar-kind 2lvar) :unknown)
+ (aver (eq (ir2-lvar-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))
+ (ir2-lvar-locs 2value)
+ (ir2-lvar-locs 2lvar)))
+ ((eq (ir2-lvar-kind 2lvar) :fixed)
+ (aver (eq (ir2-lvar-kind 2value) :fixed))
(if (cast-type-check node)
(move-results-checked node block
- (ir2-continuation-locs 2value)
- (ir2-continuation-locs 2cont)
+ (ir2-lvar-locs 2value)
+ (ir2-lvar-locs 2lvar)
(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))))
+ (ir2-lvar-locs 2value)
+ (ir2-lvar-locs 2lvar))))
(t (bug "CAST cannot be :DELAYED.")))))
\f
;;;; template conversion
(let ((type (first types))
(arg (first args)))
(if (and (consp type) (eq (car type) ':constant))
- (info-args (continuation-value arg))
- (let ((ref (reference-tn (continuation-tn node block arg) nil)))
+ (info-args (lvar-value arg))
+ (let ((ref (reference-tn (lvar-tn node block arg) nil)))
(if last
(setf (tn-ref-across last) ref)
(setf first ref))
(defun ir2-convert-if (node block)
(declare (type ir2-block block) (type cif node))
(let* ((test (if-test node))
- (test-ref (reference-tn (continuation-tn node block test) nil))
+ (test-ref (reference-tn (lvar-tn node block test) nil))
(nil-ref (reference-tn (emit-constant nil) nil)))
(setf (tn-ref-across test-ref) nil-ref)
(ir2-convert-conditional node block (template-or-lose 'if-eq)
;;; that was done in initially selecting the template, so we know that
;;; the types we find are allowed by the template output type
;;; restrictions.
-(defun find-template-result-types (call cont template rtypes)
- (declare (type combination call) (type continuation cont)
+(defun find-template-result-types (call template rtypes)
+ (declare (type combination call)
(type template template) (list rtypes))
(let* ((dtype (node-derived-type call))
(type dtype)
;;; where the continuation is fixed values and has locations that
;;; satisfy the result restrictions. This can fail when there is a
;;; type check or a values count mismatch.
-(defun make-template-result-tns (call cont template rtypes)
- (declare (type combination call) (type continuation cont)
+(defun make-template-result-tns (call lvar template rtypes)
+ (declare (type combination call) (type (or lvar null) lvar)
(type template template) (list rtypes))
- (let ((2cont (continuation-info cont)))
- (if (and 2cont (eq (ir2-continuation-kind 2cont) :fixed))
- (let ((locs (ir2-continuation-locs 2cont)))
+ (let ((2lvar (when lvar (lvar-info lvar))))
+ (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed))
+ (let ((locs (ir2-lvar-locs 2lvar)))
(if (and (= (length rtypes) (length locs))
(do ((loc locs (cdr loc))
(rtype rtypes (cdr rtype)))
:t-ok nil)
(return nil))))
locs
- (continuation-result-tns
- cont
- (find-template-result-types call cont template rtypes))))
- (continuation-result-tns
- cont
- (find-template-result-types call cont template rtypes)))))
+ (lvar-result-tns
+ lvar
+ (find-template-result-types call template rtypes))))
+ (lvar-result-tns
+ lvar
+ (find-template-result-types call template rtypes)))))
;;; 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))
(let* ((template (combination-info call))
- (cont (node-cont call))
+ (lvar (node-lvar call))
(rtypes (template-result-types template)))
(multiple-value-bind (args info-args)
(reference-args call block (combination-args call) template)
(aver (not (template-more-results-type template)))
(if (eq rtypes :conditional)
(ir2-convert-conditional call block template args info-args
- (continuation-dest cont) nil)
- (let* ((results (make-template-result-tns call cont template rtypes))
+ (lvar-dest lvar) nil)
+ (let* ((results (make-template-result-tns call lvar template rtypes))
(r-refs (reference-tn-list results t)))
(aver (= (length info-args)
(template-info-arg-count template)))
(if info-args
(emit-template call block template args r-refs info-args)
(emit-template call block template args r-refs))
- (move-continuation-result call block results cont)))))
+ (move-lvar-result call block results lvar)))))
(values))
;;; We don't have to do much because operand count checking is done by
;;; case of IR2-CONVERT-TEMPLATE is that there can be codegen-info
;;; arguments.
(defoptimizer (%%primitive ir2-convert) ((template info &rest args) call block)
- (let* ((template (continuation-value template))
- (info (continuation-value info))
- (cont (node-cont call))
+ (let* ((template (lvar-value template))
+ (info (lvar-value info))
+ (lvar (node-lvar call))
(rtypes (template-result-types template))
- (results (make-template-result-tns call cont template rtypes))
+ (results (make-template-result-tns call lvar template rtypes))
(r-refs (reference-tn-list results t)))
(multiple-value-bind (args info-args)
(reference-args call block (cddr (combination-args call)) template)
(emit-template call block template args r-refs info)
(emit-template call block template args r-refs))
- (move-continuation-result call block results cont)))
+ (move-lvar-result call block results lvar)))
(values))
\f
;;;; local call
(declare (type combination node) (type ir2-block block) (type clambda fun))
(mapc (lambda (var arg)
(when arg
- (let ((src (continuation-tn node block arg))
+ (let ((src (lvar-tn node block arg))
(dest (leaf-info var)))
(if (lambda-var-indirect var)
(do-make-value-cell node block src dest)
(type (or tn null) old-fp))
(let ((actuals (mapcar (lambda (x)
(when x
- (continuation-tn node block x)))
+ (lvar-tn node block x)))
(combination-args node))))
(collect ((temps)
(locs))
;;; Handle a non-TR known-values local call. We emit the call, then
;;; move the results to the continuation's destination.
-(defun ir2-convert-local-known-call (node block fun returns cont start)
+(defun ir2-convert-local-known-call (node block fun returns lvar start)
(declare (type node node) (type ir2-block block) (type clambda fun)
- (type return-info returns) (type continuation cont)
+ (type return-info returns) (type (or lvar null) lvar)
(type label start))
(multiple-value-bind (fp nfp temps arg-locs)
(ir2-convert-local-call-args node block fun)
(fp nfp (reference-tn-list temps nil))
((reference-tn-list locs t))
arg-locs (physenv-info (lambda-physenv fun)) start)
- (move-continuation-result node block locs cont)))
+ (move-lvar-result node block locs lvar)))
(values))
;;; Handle a non-TR unknown-values local call. We do different things
;;; Otherwise, we use STANDARD-RESULT-TNS to get wired result TNs, and
;;; then call MOVE-CONTINUATION-RESULT to do any necessary type checks
;;; or coercions.
-(defun ir2-convert-local-unknown-call (node block fun cont start)
+(defun ir2-convert-local-unknown-call (node block fun lvar start)
(declare (type node node) (type ir2-block block) (type clambda fun)
- (type continuation cont) (type label start))
+ (type (or lvar null) lvar) (type label start))
(multiple-value-bind (fp nfp temps arg-locs)
(ir2-convert-local-call-args node block fun)
- (let ((2cont (continuation-info cont))
+ (let ((2lvar (and lvar (lvar-info lvar)))
(env (physenv-info (lambda-physenv fun)))
(temp-refs (reference-tn-list temps nil)))
- (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown))
+ (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown))
(vop* multiple-call-local node block (fp nfp temp-refs)
- ((reference-tn-list (ir2-continuation-locs 2cont) t))
+ ((reference-tn-list (ir2-lvar-locs 2lvar) t))
arg-locs env start)
- (let ((locs (standard-result-tns cont)))
+ (let ((locs (standard-result-tns lvar)))
(vop* call-local node block
(fp nfp temp-refs)
((reference-tn-list locs t))
arg-locs env start (length locs))
- (move-continuation-result node block locs cont)))))
+ (move-lvar-result node block locs lvar)))))
(values))
;;; Dispatch to the appropriate function, depending on whether we have
;;; tail call, but that might seem confusing in the debugger.
(defun ir2-convert-local-call (node block)
(declare (type combination node) (type ir2-block block))
- (let* ((fun (ref-leaf (continuation-use (basic-combination-fun node))))
+ (let* ((fun (ref-leaf (lvar-uses (basic-combination-fun node))))
(kind (functional-kind fun)))
(cond ((eq kind :let)
(ir2-convert-let node block fun))
(t
(let ((start (block-label (lambda-block fun)))
(returns (tail-set-info (lambda-tail-set fun)))
- (cont (node-cont node)))
+ (lvar (node-lvar node)))
(ecase (if returns
(return-info-kind returns)
:unknown)
(:unknown
- (ir2-convert-local-unknown-call node block fun cont start))
+ (ir2-convert-local-unknown-call node block fun lvar start))
(:fixed
(ir2-convert-local-known-call node block fun returns
- cont start)))))))
+ lvar start)))))))
(values))
\f
;;;; full call
;;; -- 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)))
- (if (eq (ir2-continuation-kind 2cont) :delayed)
- (let ((name (continuation-fun-name cont t)))
+(defun fun-lvar-tn (node block lvar)
+ (declare (type lvar lvar))
+ (let ((2lvar (lvar-info lvar)))
+ (if (eq (ir2-lvar-kind 2lvar) :delayed)
+ (let ((name (lvar-fun-name lvar t)))
(aver name)
(values (make-load-time-constant-tn :fdefinition name) t))
- (let* ((locs (ir2-continuation-locs 2cont))
+ (let* ((locs (ir2-lvar-locs 2lvar))
(loc (first locs))
(function-ptype (primitive-type-or-lose 'function)))
- (aver (and (eq (ir2-continuation-kind 2cont) :fixed)
+ (aver (and (eq (ir2-lvar-kind 2lvar) :fixed)
(= (length locs) 1)))
(aver (eq (tn-primitive-type loc) function-ptype))
(values loc nil)))))
(first nil))
(dotimes (num (length args))
(let ((loc (standard-arg-location num)))
- (emit-move node block (continuation-tn node block (elt args num)) loc)
+ (emit-move node block (lvar-tn node block (elt args num)) loc)
(let ((ref (reference-tn loc nil)))
(if last
(setf (tn-ref-across last) ref)
(return-pc (ir2-physenv-return-pc env)))
(multiple-value-bind (fun-tn named)
- (fun-continuation-tn node block (basic-combination-fun node))
+ (fun-lvar-tn node block (basic-combination-fun node))
(if named
(vop* tail-call-named node block
(fun-tn old-fp return-pc pass-refs)
(first nil))
(dotimes (num nargs)
(locs (standard-arg-location num))
- (let ((ref (reference-tn (continuation-tn node block (elt args num))
+ (let ((ref (reference-tn (lvar-tn node block (elt args num))
nil)))
(if last
(setf (tn-ref-across last) ref)
(declare (type combination node) (type ir2-block block))
(multiple-value-bind (fp args arg-locs nargs)
(ir2-convert-full-call-args node block)
- (let* ((cont (node-cont node))
- (locs (standard-result-tns cont))
+ (let* ((lvar (node-lvar node))
+ (locs (standard-result-tns lvar))
(loc-refs (reference-tn-list locs t))
(nvals (length locs)))
(multiple-value-bind (fun-tn named)
- (fun-continuation-tn node block (basic-combination-fun node))
+ (fun-lvar-tn node block (basic-combination-fun node))
(if named
(vop* call-named node block (fp fun-tn args) (loc-refs)
arg-locs nargs nvals)
(vop* call node block (fp fun-tn args) (loc-refs)
arg-locs nargs nvals))
- (move-continuation-result node block locs cont))))
+ (move-lvar-result node block locs lvar))))
(values))
;;; Do full call when unknown values are desired.
(declare (type combination node) (type ir2-block block))
(multiple-value-bind (fp args arg-locs nargs)
(ir2-convert-full-call-args node block)
- (let* ((cont (node-cont node))
- (locs (ir2-continuation-locs (continuation-info cont)))
+ (let* ((lvar (node-lvar node))
+ (locs (ir2-lvar-locs (lvar-info lvar)))
(loc-refs (reference-tn-list locs t)))
(multiple-value-bind (fun-tn named)
- (fun-continuation-tn node block (basic-combination-fun node))
+ (fun-lvar-tn node block (basic-combination-fun node))
(if named
(vop* multiple-call-named node block (fp fun-tn args) (loc-refs)
arg-locs nargs)
;;; * Is this a full call to (SETF FOO) which might conflict with
;;; a DEFSETF or some such thing elsewhere in the program?
(defun ponder-full-call (node)
- (let* ((cont (basic-combination-fun node))
- (fname (continuation-fun-name cont t)))
+ (let* ((lvar (basic-combination-fun node))
+ (fname (lvar-fun-name lvar t)))
(declare (type (or symbol cons) fname))
#!+sb-show (unless (gethash fname *full-called-fnames*)
(/show (basic-combination-args node))
(/show (policy node speed) (policy node safety))
(/show (policy node compilation-speed))
- (let ((arg-types (mapcar (lambda (maybe-continuation)
- (when maybe-continuation
+ (let ((arg-types (mapcar (lambda (lvar)
+ (when lvar
(type-specifier
- (continuation-type
- maybe-continuation))))
+ (lvar-type lvar))))
(basic-combination-args node))))
(/show arg-types)))
(defun ir2-convert-full-call (node block)
(declare (type combination node) (type ir2-block block))
(ponder-full-call node)
- (let ((2cont (continuation-info (node-cont node))))
- (cond ((node-tail-p node)
- (ir2-convert-tail-full-call node block))
- ((and 2cont
- (eq (ir2-continuation-kind 2cont) :unknown))
- (ir2-convert-multiple-full-call node block))
- (t
- (ir2-convert-fixed-full-call node block))))
+ (cond ((node-tail-p node)
+ (ir2-convert-tail-full-call node block))
+ ((let ((lvar (node-lvar node)))
+ (and lvar
+ (eq (ir2-lvar-kind (lvar-info lvar)) :unknown)))
+ (ir2-convert-multiple-full-call node block))
+ (t
+ (ir2-convert-fixed-full-call node block)))
(values))
\f
;;;; entering functions
;;; RETURN-MULTIPLE.
(defun ir2-convert-return (node block)
(declare (type creturn node) (type ir2-block block))
- (let* ((cont (return-result node))
- (2cont (continuation-info cont))
- (cont-kind (ir2-continuation-kind 2cont))
+ (let* ((lvar (return-result node))
+ (2lvar (lvar-info lvar))
+ (lvar-kind (ir2-lvar-kind 2lvar))
(fun (return-lambda node))
(env (physenv-info (lambda-physenv fun)))
(old-fp (ir2-physenv-old-fp env))
(cond
((and (eq (return-info-kind returns) :fixed)
(not (xep-p fun)))
- (let ((locs (continuation-tns node block cont
+ (let ((locs (lvar-tns node block lvar
(return-info-types returns))))
(vop* known-return node block
(old-fp return-pc (reference-tn-list locs nil))
(nil)
(return-info-locations returns))))
- ((eq cont-kind :fixed)
- (let* ((types (mapcar #'tn-primitive-type (ir2-continuation-locs 2cont)))
- (cont-locs (continuation-tns node block cont types))
- (nvals (length cont-locs))
+ ((eq lvar-kind :fixed)
+ (let* ((types (mapcar #'tn-primitive-type (ir2-lvar-locs 2lvar)))
+ (lvar-locs (lvar-tns node block lvar types))
+ (nvals (length lvar-locs))
(locs (make-standard-value-tns nvals)))
(mapc (lambda (val loc)
(emit-move node block val loc))
- cont-locs
+ lvar-locs
locs)
(if (= nvals 1)
(vop return-single node block old-fp return-pc (car locs))
(nil)
nvals))))
(t
- (aver (eq cont-kind :unknown))
+ (aver (eq lvar-kind :unknown))
(vop* return-multiple node block
(old-fp return-pc
- (reference-tn-list (ir2-continuation-locs 2cont) nil))
+ (reference-tn-list (ir2-lvar-locs 2lvar) nil))
(nil)))))
(values))
;;; function as multiple values.
(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
(let ((ir2-physenv (physenv-info (node-physenv node))))
- (move-continuation-result node block
+ (move-lvar-result node block
(list (ir2-physenv-old-fp ir2-physenv)
(ir2-physenv-return-pc ir2-physenv))
- (node-cont node))))
+ (node-lvar node))))
\f
;;;; multiple values
;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates
-;;; the continuation for the correct number of values (with the
+;;; the lvarinuation for the correct number of values (with the
;;; continuation user responsible for defaulting), we can just pick
;;; them up from the continuation.
(defun ir2-convert-mv-bind (node block)
(declare (type mv-combination node) (type ir2-block block))
- (let* ((cont (first (basic-combination-args node)))
- (fun (ref-leaf (continuation-use (basic-combination-fun node))))
+ (let* ((lvar (first (basic-combination-args node)))
+ (fun (ref-leaf (lvar-uses (basic-combination-fun node))))
(vars (lambda-vars fun)))
(aver (eq (functional-kind fun) :mv-let))
(mapc (lambda (src var)
(if (lambda-var-indirect var)
(do-make-value-cell node block src dest)
(emit-move node block src dest)))))
- (continuation-tns node block cont
+ (lvar-tns node block lvar
(mapcar (lambda (x)
(primitive-type (leaf-type x)))
vars))
(defun ir2-convert-mv-call (node block)
(declare (type mv-combination node) (type ir2-block block))
(aver (basic-combination-args node))
- (let* ((start-cont (continuation-info (first (basic-combination-args node))))
- (start (first (ir2-continuation-locs start-cont)))
+ (let* ((start-lvar (lvar-info (first (basic-combination-args node))))
+ (start (first (ir2-lvar-locs start-lvar)))
(tails (and (node-tail-p node)
(lambda-tail-set (node-home-lambda node))))
- (cont (node-cont node))
- (2cont (continuation-info cont)))
+ (lvar (node-lvar node))
+ (2lvar (and lvar (lvar-info lvar))))
(multiple-value-bind (fun named)
- (fun-continuation-tn node block (basic-combination-fun node))
+ (fun-lvar-tn node block (basic-combination-fun node))
(aver (and (not named)
- (eq (ir2-continuation-kind start-cont) :unknown)))
+ (eq (ir2-lvar-kind start-lvar) :unknown)))
(cond
(tails
(let ((env (physenv-info (node-physenv node))))
(vop tail-call-variable node block start fun
(ir2-physenv-old-fp env)
(ir2-physenv-return-pc env))))
- ((and 2cont
- (eq (ir2-continuation-kind 2cont) :unknown))
+ ((and 2lvar
+ (eq (ir2-lvar-kind 2lvar) :unknown))
(vop* multiple-call-variable node block (start fun nil)
- ((reference-tn-list (ir2-continuation-locs 2cont) t))))
+ ((reference-tn-list (ir2-lvar-locs 2lvar) t))))
(t
- (let ((locs (standard-result-tns cont)))
+ (let ((locs (standard-result-tns lvar)))
(vop* call-variable node block (start fun nil)
((reference-tn-list locs t)) (length locs))
- (move-continuation-result node block locs cont)))))))
+ (move-lvar-result node block locs lvar)))))))
;;; Reset the stack pointer to the start of the specified
;;; unknown-values continuation (discarding it and all values globs on
;;; top of it.)
-(defoptimizer (%pop-values ir2-convert) ((continuation) node block)
- (let ((2cont (continuation-info (continuation-value continuation))))
- (aver (eq (ir2-continuation-kind 2cont) :unknown))
+(defoptimizer (%pop-values ir2-convert) ((lvar) node block)
+ (let ((2lvar (lvar-info (lvar-value lvar))))
+ (aver (eq (ir2-lvar-kind 2lvar) :unknown))
(vop reset-stack-pointer node block
- (first (ir2-continuation-locs 2cont)))))
+ (first (ir2-lvar-locs 2lvar)))))
;;; Deliver the values TNs to CONT using MOVE-CONTINUATION-RESULT.
(defoptimizer (values ir2-convert) ((&rest values) node block)
(let ((tns (mapcar (lambda (x)
- (continuation-tn node block x))
+ (lvar-tn node block x))
values)))
- (move-continuation-result node block tns (node-cont node))))
+ (move-lvar-result node block tns (node-lvar node))))
;;; In the normal case where unknown values are desired, we use the
;;; VALUES-LIST VOP. In the relatively unimportant case of VALUES-LIST
;;; defaulting any unsupplied values. It seems unworthwhile to
;;; optimize this case.
(defoptimizer (values-list ir2-convert) ((list) node block)
- (let* ((cont (node-cont node))
- (2cont (continuation-info cont)))
- (cond ((and 2cont
- (eq (ir2-continuation-kind 2cont) :unknown))
- (let ((locs (ir2-continuation-locs 2cont)))
+ (let* ((lvar (node-lvar node))
+ (2lvar (and lvar (lvar-info lvar))))
+ (cond ((and 2lvar
+ (eq (ir2-lvar-kind 2lvar) :unknown))
+ (let ((locs (ir2-lvar-locs 2lvar)))
(vop* values-list node block
- ((continuation-tn node block list) nil)
+ ((lvar-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)))
+ (t (aver (or (not 2lvar) ; i.e. we want to check the argument
+ (eq (ir2-lvar-kind 2lvar) :fixed)))
(ir2-convert-full-call node block)))))
(defoptimizer (%more-arg-values ir2-convert) ((context start count) 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* %more-arg-values node block
- ((continuation-tn node block context)
- (continuation-tn node block start)
- (continuation-tn node block count)
- nil)
- ((reference-tn-list locs t)))))))))
+ (binding* ((lvar (node-lvar node) :exit-if-null)
+ (2lvar (lvar-info lvar)))
+ (ecase (ir2-lvar-kind 2lvar)
+ (:fixed (ir2-convert-full-call node block))
+ (:unknown
+ (let ((locs (ir2-lvar-locs 2lvar)))
+ (vop* %more-arg-values node block
+ ((lvar-tn node block context)
+ (lvar-tn node block start)
+ (lvar-tn node block count)
+ nil)
+ ((reference-tn-list locs t))))))))
\f
;;;; special binding
;;; This is trivial, given our assumption of a shallow-binding
;;; implementation.
(defoptimizer (%special-bind ir2-convert) ((var value) node block)
- (let ((name (leaf-source-name (continuation-value var))))
- (vop bind node block (continuation-tn node block value)
+ (let ((name (leaf-source-name (lvar-value var))))
+ (vop bind node block (lvar-tn node block value)
(emit-constant name))))
(defoptimizer (%special-unbind ir2-convert) ((var) node block)
(vop unbind node block))
;;; should really be done this way, but this is the least violation of
;;; abstraction in the current setup. We don't want to wire
;;; shallow-binding assumptions into IR1tran.
-(def-ir1-translator progv ((vars vals &body body) start cont)
+(def-ir1-translator progv
+ ((vars vals &body body) start next result)
(ir1-convert
- start cont
+ start next result
(with-unique-names (bind unbind)
(once-only ((n-save-bs '(%primitive current-binding-pointer)))
`(unwind-protect
;;; IR2 converted.
(defun ir2-convert-exit (node block)
(declare (type exit node) (type ir2-block block))
- (let ((loc (find-in-physenv (find-nlx-info (exit-entry node)
- (node-cont node))
+ (let ((loc (find-in-physenv (find-nlx-info node)
(node-physenv node)))
(temp (make-stack-pointer-tn))
(value (exit-value node)))
(vop value-cell-ref node block loc temp)
(if value
- (let ((locs (ir2-continuation-locs (continuation-info value))))
+ (let ((locs (ir2-lvar-locs (lvar-info value))))
(vop unwind node block temp (first locs) (second locs)))
(let ((0-tn (emit-constant 0)))
(vop unwind node block temp 0-tn 0-tn))))
;;; cell that holds the closed unwind block.
(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
(vop value-cell-set node block
- (find-in-physenv (continuation-value info) (node-physenv node))
+ (find-in-physenv (lvar-value info) (node-physenv node))
(emit-constant 0)))
;;; We have to do a spurious move of no values to the result
(let ((args (basic-combination-args node)))
(check-catch-tag-type (first args))
(vop* throw node block
- ((continuation-tn node block (first args))
+ ((lvar-tn node block (first args))
(reference-tn-list
- (ir2-continuation-locs (continuation-info (second args)))
+ (ir2-lvar-locs (lvar-info (second args)))
nil))
(nil)))
- (move-continuation-result node block () (node-cont node))
+ (move-lvar-result node block () (node-lvar node))
(values))
;;; Emit code to set up a non-local exit. INFO is the NLX-INFO for the
;;; is responsible for building a return-PC object.
(defun emit-nlx-start (node block info tag)
(declare (type node node) (type ir2-block block) (type nlx-info info)
- (type (or continuation null) tag))
+ (type (or lvar null) tag))
(let* ((2info (nlx-info-info info))
(kind (cleanup-kind (nlx-info-cleanup info)))
(block-tn (physenv-live-tn
(ecase kind
(:catch
(vop make-catch-block node block block-tn
- (continuation-tn node block tag) target-label res))
+ (lvar-tn node block tag) target-label res))
((:unwind-protect :block :tagbody)
(vop make-unwind-block node block block-tn target-label res)))
(defun ir2-convert-entry (node block)
(declare (type entry node) (type ir2-block block))
(dolist (exit (entry-exits node))
- (let ((info (find-nlx-info node (node-cont exit))))
+ (let ((info (find-nlx-info exit)))
(when (and info
(member (cleanup-kind (nlx-info-cleanup info))
'(:block :tagbody)))
(values))
;;; Set up the unwind block for these guys.
-(defoptimizer (%catch ir2-convert) ((info-cont tag) node block)
+(defoptimizer (%catch ir2-convert) ((info-lvar tag) node block)
(check-catch-tag-type tag)
- (emit-nlx-start node block (continuation-value info-cont) tag))
-(defoptimizer (%unwind-protect ir2-convert) ((info-cont cleanup) node block)
- (emit-nlx-start node block (continuation-value info-cont) nil))
+ (emit-nlx-start node block (lvar-value info-lvar) tag))
+(defoptimizer (%unwind-protect ir2-convert) ((info-lvar cleanup) node block)
+ (emit-nlx-start node block (lvar-value info-lvar) nil))
;;; Emit the entry code for a non-local exit. We receive values and
;;; restore dynamic state.
;;; UNWIND-PROTECT case, the values receiving restores the stack
;;; pointer. In an UNWIND-PROTECT cleanup, we want to leave the stack
;;; pointer alone, since the thrown values are still out there.
-(defoptimizer (%nlx-entry ir2-convert) ((info-cont) node block)
- (let* ((info (continuation-value info-cont))
- (cont (nlx-info-continuation info))
- (2cont (continuation-info cont))
+(defoptimizer (%nlx-entry ir2-convert) ((info-lvar) node block)
+ (let* ((info (lvar-value info-lvar))
+ (lvar (nlx-info-lvar info))
(2info (nlx-info-info info))
(top-loc (ir2-nlx-info-save-sp 2info))
(start-loc (make-nlx-entry-arg-start-location))
(ecase (cleanup-kind (nlx-info-cleanup info))
((:catch :block :tagbody)
- (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown))
- (vop* nlx-entry-multiple node block
- (top-loc start-loc count-loc nil)
- ((reference-tn-list (ir2-continuation-locs 2cont) t))
- target)
- (let ((locs (standard-result-tns cont)))
- (vop* nlx-entry node block
- (top-loc start-loc count-loc nil)
- ((reference-tn-list locs t))
- target
- (length locs))
- (move-continuation-result node block locs cont))))
+ (let ((2lvar (and lvar (lvar-info lvar))))
+ (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown))
+ (vop* nlx-entry-multiple node block
+ (top-loc start-loc count-loc nil)
+ ((reference-tn-list (ir2-lvar-locs 2lvar) t))
+ target)
+ (let ((locs (standard-result-tns lvar)))
+ (vop* nlx-entry node block
+ (top-loc start-loc count-loc nil)
+ ((reference-tn-list locs t))
+ target
+ (length locs))
+ (move-lvar-result node block locs lvar)))))
(:unwind-protect
(let ((block-loc (standard-arg-location 0)))
(vop uwp-entry node block target block-loc start-loc count-loc)
- (move-continuation-result
+ (move-lvar-result
node block
(list block-loc start-loc count-loc)
- cont))))
+ lvar))))
#!+sb-dyncount
(when *collect-dynamic-statistics*
(macrolet ((def (name)
`(defoptimizer (,name ir2-convert) ((&rest args) node block)
(let* ((refs (move-tail-full-call-args node block))
- (cont (node-cont node))
- (res (continuation-result-tns
- cont
+ (lvar (node-lvar node))
+ (res (lvar-result-tns
+ lvar
(list (primitive-type (specifier-type 'list))))))
(vop* ,name node block (refs) ((first res) nil)
(length args))
- (move-continuation-result node block res cont)))))
+ (move-lvar-result node block res lvar)))))
(def list)
(def list*))
\f
(setf (block-number block) num)
#!+sb-dyncount
(when *collect-dynamic-statistics*
- (let ((first-node (continuation-next (block-start block))))
+ (let ((first-node (block-start-node block)))
(unless (or (and (bind-p first-node)
(xep-p (bind-lambda first-node)))
- (eq (continuation-fun-name
- (node-cont first-node))
+ (eq (lvar-fun-name
+ (node-lvar first-node))
'%nlx-entry))
(vop count-me
first-node
(when (and (basic-combination-p last)
(eq (basic-combination-kind last) :full))
(let* ((fun (basic-combination-fun last))
- (use (continuation-use fun))
+ (use (lvar-uses fun))
(name (and (ref-p use)
(leaf-has-source-name-p (ref-leaf use))
(leaf-source-name (ref-leaf use)))))
(if name
(emit-constant name)
(multiple-value-bind (tn named)
- (fun-continuation-tn last 2block fun)
+ (fun-lvar-tn last 2block fun)
(aver (not named))
tn)))))))
((not (eq (ir2-block-next 2block) (block-info target)))
(defun ir2-convert-block (block)
(declare (type cblock block))
(let ((2block (block-info block)))
- (do-nodes (node cont block)
+ (do-nodes (node lvar block)
(etypecase node
(ref
- (let ((2cont (continuation-info cont)))
- (when (and 2cont
- (not (eq (ir2-continuation-kind 2cont) :delayed)))
- (ir2-convert-ref node 2block))))
+ (when lvar
+ (let ((2lvar (lvar-info lvar)))
+ ;; function REF in a local call is not annotated
+ (when (and 2lvar (not (eq (ir2-lvar-kind 2lvar) :delayed)))
+ (ir2-convert-ref node 2block)))))
(combination
(let ((kind (basic-combination-kind node)))
(case kind
(t
(ir2-convert-template node 2block))))))))
(cif
- (when (continuation-info (if-test node))
+ (when (lvar-info (if-test node))
(ir2-convert-if node 2block)))
(bind
(let ((fun (bind-lambda node)))
(ir2-convert-cast node 2block))
(mv-combination
(cond
- ((eq (basic-combination-kind node) :local)
- (ir2-convert-mv-bind node 2block))
- ((eq (continuation-fun-name (basic-combination-fun node))
- '%throw)
- (ir2-convert-throw node 2block))
- (t
- (ir2-convert-mv-call node 2block))))
+ ((eq (basic-combination-kind node) :local)
+ (ir2-convert-mv-bind node 2block))
+ ((eq (lvar-fun-name (basic-combination-fun node))
+ '%throw)
+ (ir2-convert-throw node 2block))
+ (t
+ (ir2-convert-mv-call node 2block))))
(exit
(when (exit-entry node)
(ir2-convert-exit node 2block)))
;;; only be done when the result value is that argument.
(defun result-type-first-arg (call)
(declare (type combination call))
- (let ((cont (first (combination-args call))))
- (when cont (continuation-type cont))))
+ (let ((lvar (first (combination-args call))))
+ (when lvar (lvar-type lvar))))
(defun result-type-last-arg (call)
(declare (type combination call))
- (let ((cont (car (last (combination-args call)))))
- (when cont (continuation-type cont))))
+ (let ((lvar (car (last (combination-args call)))))
+ (when lvar (lvar-type lvar))))
;;; Derive the result type according to the float contagion rules, but
;;; always return a float. This is used for irrational functions that
(defun result-type-float-contagion (call)
(declare (type combination call))
(reduce #'numeric-contagion (combination-args call)
- :key #'continuation-type
+ :key #'lvar-type
:initial-value (specifier-type 'single-float)))
;;; Return a closure usable as a derive-type method for accessing the
(defun sequence-result-nth-arg (n)
(lambda (call)
(declare (type combination call))
- (let ((cont (nth (1- n) (combination-args call))))
- (when cont
- (let ((type (continuation-type cont)))
+ (let ((lvar (nth (1- n) (combination-args call))))
+ (when lvar
+ (let ((type (lvar-type lvar)))
(if (array-type-p type)
(specifier-type
`(vector ,(type-specifier (array-type-element-type type))))
(defun result-type-specifier-nth-arg (n)
(lambda (call)
(declare (type combination call))
- (let ((cont (nth (1- n) (combination-args call))))
- (when (and cont (constant-continuation-p cont))
- (careful-specifier-type (continuation-value cont))))))
+ (let ((lvar (nth (1- n) (combination-args call))))
+ (when (and lvar (constant-lvar-p lvar))
+ (careful-specifier-type (lvar-value lvar))))))
;;; Derive the type to be the type specifier which is the Nth arg,
;;; with the additional restriptions noted in the CLHS for STRING and
(defun creation-result-type-specifier-nth-arg (n)
(lambda (call)
(declare (type combination call))
- (let ((cont (nth (1- n) (combination-args call))))
- (when (and cont (constant-continuation-p cont))
- (let* ((specifier (continuation-value cont))
+ (let ((lvar (nth (1- n) (combination-args call))))
+ (when (and lvar (constant-lvar-p lvar))
+ (let* ((specifier (lvar-value lvar))
(lspecifier (if (atom specifier) (list specifier) specifier)))
(cond
((eq (car lspecifier) 'string)
;;; the remaining args still match up with their vars.
;;;
;;; We also apply the declared variable type assertion to the argument
-;;; continuations.
+;;; lvars.
(defun propagate-to-args (call fun)
(declare (type combination call) (type clambda fun))
(loop with policy = (lexenv-policy (node-lexenv call))
for args on (basic-combination-args call)
and var in (lambda-vars fun)
- for arg = (assert-continuation-type (car args)
- (leaf-type var) policy)
+ do (assert-lvar-type (car args) (leaf-type var) policy)
do (unless (leaf-refs var)
(flush-dest (car args))
(setf (car args) nil)))
-
(values))
;;; This function handles merging the tail sets if CALL is potentially
;;; We destructively modify the set for the calling function to
;;; represent both, and then change all the functions in callee's set
;;; to reference the first. If we do merge, we reoptimize the
-;;; RETURN-RESULT continuation to cause IR1-OPTIMIZE-RETURN to
-;;; recompute the tail set type.
+;;; RETURN-RESULT lvar to cause IR1-OPTIMIZE-RETURN to recompute the
+;;; tail set type.
(defun merge-tail-sets (call &optional (new-fun (combination-lambda call)))
(declare (type basic-combination call) (type clambda new-fun))
- (let ((return (continuation-dest (node-cont call))))
+ (let ((return (node-dest call)))
(when (return-p return)
(let ((call-set (lambda-tail-set (node-home-lambda call)))
(fun-set (lambda-tail-set new-fun)))
(setf (lambda-tail-set fun) call-set))
(setf (tail-set-funs call-set)
(nconc (tail-set-funs call-set) funs)))
- (reoptimize-continuation (return-result return))
+ (reoptimize-lvar (return-result return))
t)))))
;;; Convert a combination into a local call. We PROPAGATE-TO-ARGS, set
(unless (call-full-like-p call)
(dolist (arg (basic-combination-args call))
(when arg
- (flush-continuation-externally-checkable-type arg))))
+ (flush-lvar-externally-checkable-type arg))))
(pushnew fun (lambda-calls-or-closes (node-home-lambda call)))
(merge-tail-sets call fun)
(change-ref-leaf ref fun)
(make-xep fun))))))
\f
;;; Attempt to convert all references to FUN to local calls. The
-;;; reference must be the function for a call, and the function
-;;; continuation must be used only once, since otherwise we cannot be
-;;; sure what function is to be called. The call continuation would be
-;;; multiply used if there is hairy stuff such as conditionals in the
-;;; expression that computes the function.
+;;; reference must be the function for a call, and the function lvar
+;;; must be used only once, since otherwise we cannot be sure what
+;;; function is to be called. The call lvar would be multiply used if
+;;; there is hairy stuff such as conditionals in the expression that
+;;; computes the function.
;;;
;;; If we cannot convert a reference, then we mark the referenced
;;; function as an entry-point, creating a new XEP if necessary. We
(let ((refs (leaf-refs fun))
(first-time t))
(dolist (ref refs)
- (let* ((cont (node-cont ref))
- (dest (continuation-dest cont)))
+ (let* ((lvar (node-lvar ref))
+ (dest (when lvar (lvar-dest lvar))))
(cond ((and (basic-combination-p dest)
- (eq (basic-combination-fun dest) cont)
- (eq (continuation-use cont) ref))
+ (eq (basic-combination-fun dest) lvar)
+ (eq (lvar-uses lvar) ref))
(convert-call-if-possible ref dest)
;;; Attempt to convert a multiple-value call. The only interesting
;;; case is a call to a function that LOOKS-LIKE-AN-MV-BIND, has
;;; exactly one reference and no XEP, and is called with one values
-;;; continuation.
+;;; lvar.
;;;
;;; We change the call to be to the last optional entry point and
;;; change the call to be local. Due to our preconditions, the call
;;; optional defaulting code.
;;;
;;; We also use variable types for the called function to construct an
-;;; assertion for the values continuation.
+;;; assertion for the values lvar.
;;;
;;; See CONVERT-CALL for additional notes on MERGE-TAIL-SETS, etc.
(defun convert-mv-call (ref call fun)
(declare (type ref ref) (type mv-combination call) (type functional fun))
(when (and (looks-like-an-mv-bind fun)
(not (functional-entry-fun fun))
- (= (length (leaf-refs fun)) 1)
- (= (length (basic-combination-args call)) 1))
+ (singleton-p (leaf-refs fun))
+ (singleton-p (basic-combination-args call)))
(let* ((*current-component* (node-component ref))
(ep (optional-dispatch-entry-point-fun
fun (optional-dispatch-max-args fun))))
(merge-tail-sets call ep)
(change-ref-leaf ref ep)
- (assert-continuation-type
+ (assert-lvar-type
(first (basic-combination-args call))
(make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
(lexenv-policy (node-lexenv call)))))
(defun convert-lambda-call (ref call fun)
(declare (type ref ref) (type combination call) (type clambda fun))
(let ((nargs (length (lambda-vars fun)))
- (call-args (length (combination-args call))))
- (cond ((= call-args nargs)
+ (n-call-args (length (combination-args call))))
+ (cond ((= n-call-args nargs)
(convert-call ref call fun))
(t
;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the
;; file. So maybe it deserves a full warning anyway.
(compiler-warn
"function called with ~R argument~:P, but wants exactly ~R"
- call-args nargs)
+ n-call-args nargs)
(setf (basic-combination-kind call) :error)))))
\f
;;;; &OPTIONAL, &MORE and &KEYWORD calls
(declare (ignorable ,@ignores))
(%funcall ,entry ,@args))
:debug-name (debug-namify "hairy function entry ~S"
- (continuation-fun-name
+ (lvar-fun-name
(basic-combination-fun call)))))))
(convert-call ref call new-fun)
(dolist (ref (leaf-refs entry))
- (convert-call-if-possible ref (continuation-dest (node-cont ref))))))
+ (convert-call-if-possible ref (lvar-dest (node-lvar ref))))))
;;; Use CONVERT-HAIRY-FUN-ENTRY to convert a &MORE-arg call to a known
;;; function into a local call to the MAIN-ENTRY.
(do ((key more (cddr key))
(temp more-temps (cddr temp)))
((null key))
- (let ((cont (first key)))
- (unless (constant-continuation-p cont)
+ (let ((lvar (first key)))
+ (unless (constant-lvar-p lvar)
(when flame
(compiler-notify "non-constant keyword in keyword call"))
(setf (basic-combination-kind call) :error)
(return-from convert-more-call))
- (let ((name (continuation-value cont))
+ (let ((name (lvar-value lvar))
(dummy (first temp))
(val (second temp)))
;; FIXME: check whether KEY was supplied earlier
(when (and (eq name :allow-other-keys) (not allow-found))
(let ((val (second key)))
- (cond ((constant-continuation-p val)
+ (cond ((constant-lvar-p val)
(setq allow-found t
- allowp (continuation-value val)))
+ allowp (lvar-value val)))
(t (when flame
(compiler-notify "non-constant :ALLOW-OTHER-KEYS value"))
(setf (basic-combination-kind call) :error)
;;;; corresponding combination node, making the control transfer
;;;; explicit and allowing LETs to be mashed together into a single
;;;; block. The value of the LET is delivered directly to the
-;;;; original continuation for the call, eliminating the need to
-;;;; propagate information from the dummy result continuation.
+;;;; original lvar for the call, eliminating the need to
+;;;; propagate information from the dummy result lvar.
;;;; -- As far as IR1 optimization is concerned, it is interesting in
;;;; that there is only one expression that the variable can be bound
;;;; to, and this is easily substituted for.
(join-components component clambda-component)))
(let ((*current-component* component))
(node-ends-block call))
- ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other
- ;; uses of '=.*length' which could also be converted to use
- ;; DESTRUCTURING-BIND or PROPER-LIST-OF-LENGTH-P.
- (aver (= (length (block-succ call-block)) 1))
- (let ((next-block (first (block-succ call-block))))
+ (destructuring-bind (next-block)
+ (block-succ call-block)
(unlink-blocks call-block next-block)
(link-blocks call-block bind-block)
next-block)))
;;; Handle the value semantics of LET conversion. Delete FUN's return
;;; node, and change the control flow to transfer to NEXT-BLOCK
-;;; instead. Move all the uses of the result continuation to CALL's
-;;; CONT.
+;;; instead. Move all the uses of the result lvar to CALL's lvar.
(defun move-return-uses (fun call next-block)
(declare (type clambda fun) (type basic-combination call)
(type cblock next-block))
(let* ((return (lambda-return fun))
- (return-block (node-block return)))
+ (return-block (progn
+ (ensure-block-start (node-prev return))
+ (node-block return))))
(unlink-blocks return-block
(component-tail (block-component return-block)))
(link-blocks return-block next-block)
(unlink-node return)
(delete-return return)
(let ((result (return-result return))
- (cont (node-cont call))
- (call-type (node-derived-type call)))
+ (lvar (if (node-tail-p call)
+ (return-result (lambda-return (node-home-lambda call)))
+ (node-lvar call)))
+ (call-type (node-derived-type call)))
(unless (eq call-type *wild-type*)
- ;; FIXME: Replace the call with unsafe CAST. -- APD, 2002-01-26
+ ;; FIXME: Replace the call with unsafe CAST. -- APD, 2003-01-26
(do-uses (use result)
- (derive-node-type use call-type)))
- (substitute-continuation-uses cont result)))
- (values))
-
-;;; Change all CONT for all the calls to FUN to be the start
-;;; continuation for the bind node. This allows the blocks to be
-;;; joined if the caller count ever goes to one.
-(defun move-let-call-cont (fun)
- (declare (type clambda fun))
- (let ((new-cont (node-prev (lambda-bind fun))))
- (dolist (ref (leaf-refs fun))
- (let ((dest (continuation-dest (node-cont ref))))
- (delete-continuation-use dest)
- (add-continuation-use dest new-cont))))
+ (derive-node-type use call-type)))
+ (substitute-lvar-uses lvar result)))
(values))
;;; We are converting FUN to be a LET when the call is in a non-tail
(dolist (called (lambda-calls-or-closes fun))
(when (lambda-p called)
(dolist (ref (leaf-refs called))
- (let ((this-call (continuation-dest (node-cont ref))))
+ (let ((this-call (node-dest ref)))
(when (and this-call
(node-tail-p this-call)
(eq (node-home-lambda this-call) fun))
(ecase (functional-kind called)
((nil :cleanup :optional)
(let ((block (node-block this-call))
- (cont (node-cont call)))
- (ensure-block-start cont)
+ (lvar (node-lvar call)))
(unlink-blocks block (first (block-succ block)))
(link-blocks block next-block)
- (delete-continuation-use this-call)
- (add-continuation-use this-call cont)))
+ (aver (not (node-lvar this-call)))
+ (add-lvar-use this-call lvar)))
(:deleted)
;; The called function might be an assignment in the
;; case where we are currently converting that function.
;;; tail-recursive local calls.
;;; -- If CALL is a non-tail call, or if both have returns, then
;;; we delete the callee's return, move its uses to the call's
-;;; result continuation, and transfer control to the appropriate
+;;; result lvar, and transfer control to the appropriate
;;; return point.
;;; -- If the callee has a return, but the caller doesn't, then we
;;; move the return to the caller.
(let* ((return (lambda-return fun))
(call-fun (node-home-lambda call))
(call-return (lambda-return call-fun)))
+ (when (and call-return
+ (block-delete-p (node-block call-return)))
+ (delete-return call-return)
+ (unlink-node call-return)
+ (setq call-return nil))
(cond ((not return))
((or next-block call-return)
(unless (block-delete-p (node-block return))
- (when (and (node-tail-p call)
- call-return
- (not (eq (node-cont call)
- (return-result call-return))))
- ;; We do not care to give a meaningful continuation to
- ;; a tail combination, but here we need it.
- (delete-continuation-use call)
- (add-continuation-use call (return-result call-return)))
- (move-return-uses fun call
- (or next-block
- (let ((block (node-block call-return)))
- (when (block-delete-p block)
- (setf (block-delete-p block) nil))
- block)))))
+ (unless next-block
+ (ensure-block-start (node-prev call-return))
+ (setq next-block (node-block call-return)))
+ (move-return-uses fun call next-block)))
(t
(aver (node-tail-p call))
(setf (lambda-return call-fun) return)
(setf (return-lambda return) call-fun)
(setf (lambda-return fun) nil))))
- (move-let-call-cont fun)
+ (%delete-lvar-use call) ; LET call does not have value semantics
(values))
;;; Actually do LET conversion. We call subfunctions to do most of the
;;; work. We change the CALL's CONT to be the continuation heading the
-;;; BIND block, and also do REOPTIMIZE-CONTINUATION on the args and
+;;; BIND block, and also do REOPTIMIZE-LVAR on the args and
;;; CONT so that LET-specific IR1 optimizations get a chance. We blow
;;; away any entry for the function in *FREE-FUNS* so that nobody
;;; will create new references to it.
(declare (type basic-combination call))
(dolist (arg (basic-combination-args call))
(when arg
- (reoptimize-continuation arg)))
- (reoptimize-continuation (node-cont call))
+ (reoptimize-lvar arg)))
+ (reoptimize-lvar (node-lvar call))
(values))
;;; Are there any declarations in force to say CLAMBDA shouldn't be
(let ((refs (leaf-refs clambda)))
(when (and refs
(null (rest refs))
- (member (functional-kind clambda) '(nil :assignment))
+ (memq (functional-kind clambda) '(nil :assignment))
(not (functional-entry-fun clambda)))
- (let* ((ref (first refs))
- (ref-cont (node-cont ref))
- (dest (continuation-dest ref-cont)))
- (when (and dest
- (basic-combination-p dest)
- (eq (basic-combination-fun dest) ref-cont)
+ (binding* ((ref (first refs))
+ (ref-lvar (node-lvar ref) :exit-if-null)
+ (dest (lvar-dest ref-lvar)))
+ (when (and (basic-combination-p dest)
+ (eq (basic-combination-fun dest) ref-lvar)
(eq (basic-combination-kind dest) :local)
(not (block-delete-p (node-block dest)))
(cond ((ok-initial-convert-p clambda) t)
(t
- (reoptimize-continuation ref-cont)
+ (reoptimize-lvar ref-lvar)
nil)))
(when (eq clambda (node-home-lambda dest))
(delete-lambda clambda)
;;; If a potentially TR local call really is TR, then convert it to
;;; jump directly to the called function. We also call
;;; MAYBE-CONVERT-TO-ASSIGNMENT. The first value is true if we
-;;; tail-convert. The second is the value of M-C-T-A. We can switch
-;;; the succesor (potentially deleting the RETURN node) unless:
-;;; -- The call has already been converted.
-;;; -- The call isn't TR (some implicit MV PROG1.)
-;;; -- The call is in an XEP (thus we might decide to make it non-tail
-;;; so that we can use known return inside the component.)
-;;; -- There is a change in the cleanup between the call in the return,
-;;; so we might need to introduce cleanup code.
+;;; tail-convert. The second is the value of M-C-T-A.
(defun maybe-convert-tail-local-call (call)
(declare (type combination call))
- (let ((return (continuation-dest (node-cont call))))
+ (let ((return (lvar-dest (node-lvar call))))
(aver (return-p return))
- (when (and (not (node-tail-p call))
+ (when (and (not (node-tail-p call)) ; otherwise already converted
+ ;; this is a tail call
(immediately-used-p (return-result return) call)
- (not (eq (functional-kind (node-home-lambda call))
- :external))
(only-harmless-cleanups (node-block call)
- (node-block return)))
+ (node-block return))
+ ;; If the call is in an XEP, we might decide to make it
+ ;; non-tail so that we can use known return inside the
+ ;; component.
+ (not (eq (functional-kind (node-home-lambda call))
+ :external)))
(node-ends-block call)
(let ((block (node-block call))
(fun (combination-lambda call)))
(setf (node-tail-p call) t)
(unlink-blocks block (first (block-succ block)))
(link-blocks block (lambda-block fun))
+ (delete-lvar-use call)
(values t (maybe-convert-to-assignment fun))))))
;;; This is called when we believe it might make sense to convert
(let ((outside-non-tail-call nil)
(outside-call nil))
(when (and (dolist (ref (leaf-refs clambda) t)
- (let ((dest (continuation-dest (node-cont ref))))
+ (let ((dest (lvar-dest (node-lvar ref))))
(when (or (not dest)
(block-delete-p (node-block dest)))
(return nil))
((:small :fast) nil)))
;;; an annotated continuation's primitive-type
-#!-sb-fluid (declaim (inline continuation-ptype))
-(defun continuation-ptype (cont)
- (declare (type continuation cont))
- (ir2-continuation-primitive-type (continuation-info cont)))
+#!-sb-fluid (declaim (inline lvar-ptype))
+(defun lvar-ptype (lvar)
+ (declare (type lvar lvar))
+ (ir2-lvar-primitive-type (lvar-info lvar)))
;;; Return true if a constant LEAF is of a type which we can legally
;;; directly reference in code. Named constants with arbitrary pointer
(symbol (symbol-package (constant-value leaf)))
(t nil))))
-;;; If CONT is used only by a REF to a leaf that can be delayed, then
+;;; If LVAR is used only by a REF to a leaf that can be delayed, then
;;; return the leaf, otherwise return NIL.
-(defun continuation-delayed-leaf (cont)
- (declare (type continuation cont))
- (let ((use (continuation-use cont)))
+(defun lvar-delayed-leaf (lvar)
+ (declare (type lvar lvar))
+ (let ((use (lvar-uses lvar)))
(and (ref-p use)
(let ((leaf (ref-leaf use)))
(etypecase leaf
(constant (if (legal-immediate-constant-p leaf) leaf nil))
((or functional global-var) nil))))))
-;;; Annotate a normal single-value continuation. If its only use is a
-;;; ref that we are allowed to delay the evaluation of, then we mark
-;;; the continuation for delayed evaluation, otherwise we assign a TN
-;;; to hold the continuation's value.
-(defun annotate-1-value-continuation (cont)
- (declare (type continuation cont))
- (let ((info (continuation-info cont)))
- (aver (eq (ir2-continuation-kind info) :fixed))
+;;; Annotate a normal single-value lvar. If its only use is a ref that
+;;; we are allowed to delay the evaluation of, then we mark the lvar
+;;; for delayed evaluation, otherwise we assign a TN to hold the
+;;; lvar's value.
+(defun annotate-1-value-lvar (lvar)
+ (declare (type lvar lvar))
+ (let ((info (lvar-info lvar)))
+ (aver (eq (ir2-lvar-kind info) :fixed))
(cond
- ((continuation-delayed-leaf cont)
- (setf (ir2-continuation-kind info) :delayed))
- (t (setf (ir2-continuation-locs info)
- (list (make-normal-tn (ir2-continuation-primitive-type info)))))))
- (ltn-annotate-casts cont)
+ ((lvar-delayed-leaf lvar)
+ (setf (ir2-lvar-kind info) :delayed))
+ (t (setf (ir2-lvar-locs info)
+ (list (make-normal-tn (ir2-lvar-primitive-type info)))))))
+ (ltn-annotate-casts lvar)
(values))
-;;; Make an IR2-CONTINUATION corresponding to the continuation type
-;;; and then do ANNOTATE-1-VALUE-CONTINUATION.
-(defun annotate-ordinary-continuation (cont)
- (declare (type continuation cont))
- (let ((info (make-ir2-continuation
- (primitive-type (continuation-type cont)))))
- (setf (continuation-info cont) info)
- (annotate-1-value-continuation cont))
+;;; Make an IR2-LVAR corresponding to the lvar type and then do
+;;; ANNOTATE-1-VALUE-LVAR.
+(defun annotate-ordinary-lvar (lvar)
+ (declare (type lvar lvar))
+ (let ((info (make-ir2-lvar
+ (primitive-type (lvar-type lvar)))))
+ (setf (lvar-info lvar) info)
+ (annotate-1-value-lvar lvar))
(values))
-;;; Annotate the function continuation for a full call. If the only
-;;; reference is to a global function and DELAY is true, then we delay
-;;; the reference, otherwise we annotate for a single value.
-(defun annotate-fun-continuation (cont &optional (delay t))
- (declare (type continuation cont))
- (let* ((tn-ptype (primitive-type (continuation-type cont)))
- (info (make-ir2-continuation tn-ptype)))
- (setf (continuation-info cont) info)
- (let ((name (continuation-fun-name cont t)))
+;;; Annotate the function lvar for a full call. If the only reference
+;;; is to a global function and DELAY is true, then we delay the
+;;; reference, otherwise we annotate for a single value.
+(defun annotate-fun-lvar (lvar &optional (delay t))
+ (declare (type lvar lvar))
+ (let* ((tn-ptype (primitive-type (lvar-type lvar)))
+ (info (make-ir2-lvar tn-ptype)))
+ (setf (lvar-info lvar) info)
+ (let ((name (lvar-fun-name lvar t)))
(if (and delay name)
- (setf (ir2-continuation-kind info) :delayed)
- (setf (ir2-continuation-locs info)
+ (setf (ir2-lvar-kind info) :delayed)
+ (setf (ir2-lvar-locs info)
(list (make-normal-tn tn-ptype))))))
- (ltn-annotate-casts cont)
+ (ltn-annotate-casts lvar)
(values))
-;;; If TAIL-P is true, then we check to see whether the call can really
-;;; be a tail call by seeing if this function's return convention is :UNKNOWN.
-;;; If so, we move the call block succssor link from the return block to
-;;; the component tail (after ensuring that they are in separate blocks.)
-;;; This allows the return to be deleted when there are no non-tail uses.
+;;; If TAIL-P is true, then we check to see whether the call can
+;;; really be a tail call by seeing if this function's return
+;;; convention is :UNKNOWN. If so, we move the call block successor
+;;; link from the return block to the component tail (after ensuring
+;;; that they are in separate blocks.) This allows the return to be
+;;; deleted when there are no non-tail uses.
(defun flush-full-call-tail-transfer (call)
(declare (type basic-combination call))
(let ((tails (and (node-tail-p call)
;;; We set the kind to :FULL or :FUNNY, depending on whether there is
;;; an IR2-CONVERT method. If a funny function, then we inhibit tail
;;; recursion normally, since the IR2 convert method is going to want
-;;; to deliver values normally. We still annotate the function
-;;; continuation, since IR2tran might decide to call after all.
+;;; to deliver values normally. We still annotate the function lvar,
+;;; since IR2tran might decide to call after all.
;;;
;;; Note that args may already be annotated because template selection
;;; can bail out to here.
(defun ltn-default-call (call)
(declare (type combination call))
(let ((kind (basic-combination-kind call)))
- (annotate-fun-continuation (basic-combination-fun call))
+ (annotate-fun-lvar (basic-combination-fun call))
+
+ (dolist (arg (basic-combination-args call))
+ (unless (lvar-info arg)
+ (setf (lvar-info arg)
+ (make-ir2-lvar (primitive-type (lvar-type arg)))))
+ (annotate-1-value-lvar arg))
(cond
((and (fun-info-p kind)
(fun-info-ir2-convert kind))
(setf (basic-combination-info call) :funny)
- (setf (node-tail-p call) nil)
- (dolist (arg (basic-combination-args call))
- (unless (continuation-info arg)
- (setf (continuation-info arg)
- (make-ir2-continuation
- (primitive-type
- (continuation-type arg)))))
- (annotate-1-value-continuation arg)))
+ (setf (node-tail-p call) nil))
(t
- (dolist (arg (basic-combination-args call))
- (unless (continuation-info arg)
- (setf (continuation-info arg)
- (make-ir2-continuation
- (primitive-type
- (continuation-type arg)))))
- (annotate-1-value-continuation arg))
(when (eq kind :error)
(setf (basic-combination-kind call) :full))
(setf (basic-combination-info call) :full)
(values))
-;;; Annotate a continuation for unknown multiple values:
-;;; -- Add the continuation to the IR2-BLOCK-POPPED if it is used
-;;; across a block boundary.
-;;; -- Assign an :UNKNOWN IR2-CONTINUATION.
+;;; Annotate an lvar for unknown multiple values:
+;;; -- Add the lvar to the IR2-BLOCK-POPPED if it is used across a
+;;; block boundary.
+;;; -- Assign an :UNKNOWN IR2-LVAR.
;;;
;;; Note: it is critical that this be called only during LTN analysis
-;;; of CONT's DEST, and called in the order that the continuations are
+;;; of LVAR's DEST, and called in the order that the lvarss are
;;; received. Otherwise the IR2-BLOCK-POPPED and
;;; IR2-COMPONENT-VALUES-FOO would get all messed up.
-(defun annotate-unknown-values-continuation (cont)
- (declare (type continuation cont))
-
- (let ((2cont (make-ir2-continuation nil)))
- (setf (ir2-continuation-kind 2cont) :unknown)
- (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
- (setf (continuation-info cont) 2cont))
-
- ;; The CAST chain with corresponding continuations constitute the
- ;; same "principal continuation", so we must preserve only inner
- ;; annotation order and the order of the whole p.c. with other
- ;; continiations. -- APD, 2002-02-27
- (ltn-annotate-casts cont)
-
- (let* ((block (node-block (continuation-dest cont)))
- (use (continuation-use cont))
+(defun annotate-unknown-values-lvar (lvar)
+ (declare (type lvar lvar))
+
+ (let ((2lvar (make-ir2-lvar nil)))
+ (setf (ir2-lvar-kind 2lvar) :unknown)
+ (setf (ir2-lvar-locs 2lvar) (make-unknown-values-locations))
+ (setf (lvar-info lvar) 2lvar))
+
+ ;; The CAST chain with corresponding lvars constitute the same
+ ;; "principal lvar", so we must preserve only inner annotation order
+ ;; and the order of the whole p.l. with other lvars. -- APD,
+ ;; 2003-02-27
+ (ltn-annotate-casts lvar)
+
+ (let* ((block (node-block (lvar-dest lvar)))
+ (use (lvar-uses lvar))
(2block (block-info block)))
- (unless (and use (eq (node-block use) block))
+ (unless (and (not (listp use)) (eq (node-block use) block))
(setf (ir2-block-popped 2block)
- (nconc (ir2-block-popped 2block) (list cont)))))
+ (nconc (ir2-block-popped 2block) (list lvar)))))
(values))
-;;; Annotate CONT for a fixed, but arbitrary number of values, of the
+;;; Annotate LVAR for a fixed, but arbitrary number of values, of the
;;; specified primitive TYPES.
-(defun annotate-fixed-values-continuation (cont types)
- (declare (type continuation cont) (list types))
- (let ((res (make-ir2-continuation nil)))
- (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
- (setf (continuation-info cont) res))
- (ltn-annotate-casts cont)
+(defun annotate-fixed-values-lvar (lvar types)
+ (declare (type lvar lvar) (list types))
+ (let ((res (make-ir2-lvar nil)))
+ (setf (ir2-lvar-locs res) (mapcar #'make-normal-tn types))
+ (setf (lvar-info lvar) res))
+ (ltn-annotate-casts lvar)
(values))
\f
;;;; node-specific analysis functions
-;;; Annotate the result continuation for a function. We use the
-;;; RETURN-INFO computed by GTN to determine how to represent the
-;;; return values within the function:
-;;; * If the TAIL-SET has a fixed values count, then use that
-;;; many values.
-;;; * If the actual uses of the result continuation in this function
+;;; Annotate the result lvar for a function. We use the RETURN-INFO
+;;; computed by GTN to determine how to represent the return values
+;;; within the function:
+;;; * If the TAIL-SET has a fixed values count, then use that many
+;;; values.
+;;; * If the actual uses of the result lvar in this function
;;; have a fixed number of values (after intersection with the
;;; assertion), then use that number. We throw out TAIL-P :FULL
;;; and :LOCAL calls, since we know they will truly end up as TR
;;; If there are *no* non-tail-call uses, then it falls out
;;; that we annotate for one value (type is NIL), but the return
;;; will end up being deleted.
-;;; In non-perverse code, the DFO walk will reach all uses of
-;;; the result continuation before it reaches the RETURN. In
-;;; perverse code, we may annotate for unknown values when we
-;;; didn't have to.
-;;; * Otherwise, we must annotate the continuation for unknown values.
+;;; In non-perverse code, the DFO walk will reach all uses of the
+;;; result lvar before it reaches the RETURN. In perverse code, we
+;;; may annotate for unknown values when we didn't have to.
+;;; * Otherwise, we must annotate the lvar for unknown values.
(defun ltn-analyze-return (node)
(declare (type creturn node))
- (let* ((cont (return-result node))
+ (let* ((lvar (return-result node))
(fun (return-lambda node))
(returns (tail-set-info (lambda-tail-set fun)))
(types (return-info-types returns)))
(values nil :unknown)
(values-types int))
(if (eq kind :unknown)
- (annotate-unknown-values-continuation cont)
- (annotate-fixed-values-continuation
- cont (mapcar #'primitive-type types))))))
- (annotate-fixed-values-continuation cont types)))
+ (annotate-unknown-values-lvar lvar)
+ (annotate-fixed-values-lvar
+ lvar (mapcar #'primitive-type types))))))
+ (annotate-fixed-values-lvar lvar types)))
(values))
-;;; Annotate the single argument continuation as a fixed-values
-;;; continuation. We look at the called lambda to determine number and
-;;; type of return values desired. It is assumed that only a function
-;;; that LOOKS-LIKE-AN-MV-BIND will be converted to a local call.
+;;; Annotate the single argument lvar as a fixed-values lvar. We look
+;;; at the called lambda to determine number and type of return values
+;;; desired. It is assumed that only a function that
+;;; LOOKS-LIKE-AN-MV-BIND will be converted to a local call.
(defun ltn-analyze-mv-bind (call)
(declare (type mv-combination call))
(setf (basic-combination-kind call) :local)
(setf (node-tail-p call) nil)
- (annotate-fixed-values-continuation
+ (annotate-fixed-values-lvar
(first (basic-combination-args call))
(mapcar (lambda (var)
(primitive-type (basic-var-type var)))
(lambda-vars
- (ref-leaf
- (continuation-use
- (basic-combination-fun call))))))
+ (ref-leaf (lvar-use (basic-combination-fun call))))))
(values))
-;;; We force all the argument continuations to use the unknown values
-;;; convention. The continuations are annotated in reverse order,
-;;; since the last argument is on top, thus must be popped first. We
-;;; disallow delayed evaluation of the function continuation to
-;;; simplify IR2 conversion of MV call.
+;;; We force all the argument lvars to use the unknown values
+;;; convention. The lvars are annotated in reverse order, since the
+;;; last argument is on top, thus must be popped first. We disallow
+;;; delayed evaluation of the function lvar to simplify IR2 conversion
+;;; of MV call.
;;;
;;; We could be cleverer when we know the number of values returned by
-;;; the continuations, but optimizations of MV call are probably
-;;; unworthwhile.
+;;; the lvars, but optimizations of MV call are probably unworthwhile.
;;;
;;; We are also responsible for handling THROW, which is represented
;;; in IR1 as an MV call to the %THROW funny function. We annotate the
-;;; tag continuation for a single value and the values continuation
-;;; for unknown values.
+;;; tag lvar for a single value and the values lvar for unknown
+;;; values.
(defun ltn-analyze-mv-call (call)
(declare (type mv-combination call))
(let ((fun (basic-combination-fun call))
(args (basic-combination-args call)))
- (cond ((eq (continuation-fun-name fun) '%throw)
+ (cond ((eq (lvar-fun-name fun) '%throw)
(setf (basic-combination-info call) :funny)
- (annotate-ordinary-continuation (first args))
- (annotate-unknown-values-continuation (second args))
+ (annotate-ordinary-lvar (first args))
+ (annotate-unknown-values-lvar (second args))
(setf (node-tail-p call) nil))
(t
(setf (basic-combination-info call) :full)
- (annotate-fun-continuation (basic-combination-fun call)
+ (annotate-fun-lvar (basic-combination-fun call)
nil)
(dolist (arg (reverse args))
- (annotate-unknown-values-continuation arg))
+ (annotate-unknown-values-lvar arg))
(flush-full-call-tail-transfer call))))
(values))
-;;; Annotate the arguments as ordinary single-value continuations. And
-;;; check the successor.
+;;; Annotate the arguments as ordinary single-value lvars. And check
+;;; the successor.
(defun ltn-analyze-local-call (call)
(declare (type combination call))
(setf (basic-combination-info call) :local)
(dolist (arg (basic-combination-args call))
(when arg
- (annotate-ordinary-continuation arg)))
+ (annotate-ordinary-lvar arg)))
(when (node-tail-p call)
(set-tail-local-call-successor call))
(values))
(link-blocks block (lambda-block callee))))
(values))
-;;; Annotate the value continuation.
+;;; Annotate the value lvar.
(defun ltn-analyze-set (node)
(declare (type cset node))
(setf (node-tail-p node) nil)
- (annotate-ordinary-continuation (set-value node))
+ (annotate-ordinary-lvar (set-value node))
(values))
-;;; If the only use of the TEST continuation is a combination
-;;; annotated with a conditional template, then don't annotate the
-;;; continuation so that IR2 conversion knows not to emit any code,
-;;; otherwise annotate as an ordinary continuation. Since we only use
-;;; a conditional template if the call immediately precedes the IF
-;;; node in the same block, we know that any predicate will already be
-;;; annotated.
+;;; If the only use of the TEST lvar is a combination annotated with a
+;;; conditional template, then don't annotate the lvar so that IR2
+;;; conversion knows not to emit any code, otherwise annotate as an
+;;; ordinary lvar. Since we only use a conditional template if the
+;;; call immediately precedes the IF node in the same block, we know
+;;; that any predicate will already be annotated.
(defun ltn-analyze-if (node)
(declare (type cif node))
(setf (node-tail-p node) nil)
(let* ((test (if-test node))
- (use (continuation-use test)))
+ (use (lvar-uses test)))
(unless (and (combination-p use)
(let ((info (basic-combination-info use)))
(and (template-p info)
(eq (template-result-types info) :conditional))))
- (annotate-ordinary-continuation test)))
+ (annotate-ordinary-lvar test)))
(values))
-;;; If there is a value continuation, then annotate it for unknown
-;;; values. In this case, the exit is non-local, since all other exits
-;;; are deleted or degenerate by this point.
+;;; If there is a value lvar, then annotate it for unknown values. In
+;;; this case, the exit is non-local, since all other exits are
+;;; deleted or degenerate by this point.
(defun ltn-analyze-exit (node)
(setf (node-tail-p node) nil)
(let ((value (exit-value node)))
(when value
- (annotate-unknown-values-continuation value)))
+ (annotate-unknown-values-lvar value)))
(values))
;;; We need a special method for %UNWIND-PROTECT that ignores the
;;; be made, and by representation selection when it is deciding which
;;; move VOP to use. CONT and TN are used to test for constant
;;; arguments.
-(defun operand-restriction-ok (restr type &key cont tn (t-ok t))
+(defun operand-restriction-ok (restr type &key lvar tn (t-ok t))
(declare (type (or (member *) cons) restr)
(type primitive-type type)
- (type (or continuation null) cont)
+ (type (or lvar null) lvar)
(type (or tn null) tn))
(if (eq restr '*)
t
(eq mem type))
(return t))))
(:constant
- (cond (cont
- (and (constant-continuation-p cont)
- (funcall (second restr) (continuation-value cont))))
+ (cond (lvar
+ (and (constant-lvar-p lvar)
+ (funcall (second restr) (lvar-value lvar))))
(tn
(and (eq (tn-kind tn) :constant)
(funcall (second restr) (tn-value tn))))
(t
- (error "Neither CONT nor TN supplied.")))))))
+ (error "Neither LVAR nor TN supplied.")))))))
;;; Check that the argument type restriction for TEMPLATE are
;;; satisfied in call. If an argument's TYPE-CHECK is :NO-CHECK and
(t
(dolist (arg args t)
(unless (operand-restriction-ok mtype
- (continuation-ptype arg))
+ (lvar-ptype arg))
(return nil))))))
(when (null args) (return nil))
(let ((arg (car args))
(type (car types)))
- (unless (operand-restriction-ok type (continuation-ptype arg)
- :cont arg)
+ (unless (operand-restriction-ok type (lvar-ptype arg)
+ :lvar arg)
(return nil))))))
;;; Check that TEMPLATE can be used with the specifed RESULT-TYPE.
(defun is-ok-template-use (template call safe-p)
(declare (type template template) (type combination call))
(let* ((guard (template-guard template))
- (cont (node-cont call))
+ (lvar (node-lvar call))
(dtype (node-derived-type call)))
(cond ((and guard (not (funcall guard)))
(values nil :guard))
:arg-check
:arg-types)))
((eq (template-result-types template) :conditional)
- (let ((dest (continuation-dest cont)))
+ (let ((dest (lvar-dest lvar)))
(if (and (if-p dest)
(immediately-used-p (if-test dest) call))
(values t nil)
(funcall frob "argument primitive types:~% ~S"
(mapcar (lambda (x)
(primitive-type-name
- (continuation-ptype x)))
+ (lvar-ptype x)))
(combination-args call)))
(funcall frob "argument type assertions:~% ~S"
(mapcar (lambda (x)
(values))
;;; If a function has a special-case annotation method use that,
-;;; otherwise annotate the argument continuations and try to find a
-;;; template corresponding to the type signature. If there is none,
-;;; convert a full call.
+;;; otherwise annotate the argument lvars and try to find a template
+;;; corresponding to the type signature. If there is none, convert a
+;;; full call.
(defun ltn-analyze-known-call (call)
(declare (type combination call))
(let ((ltn-policy (node-ltn-policy call))
(return-from ltn-analyze-known-call (values)))
(dolist (arg args)
- (setf (continuation-info arg)
- (make-ir2-continuation (primitive-type (continuation-type arg)))))
+ (setf (lvar-info arg)
+ (make-ir2-lvar (primitive-type (lvar-type arg)))))
(multiple-value-bind (template rejected)
(find-template-for-ltn-policy call ltn-policy)
(unless template
(when (let ((funleaf (physenv-lambda (node-physenv call))))
(and (leaf-has-source-name-p funleaf)
- (eq (continuation-fun-name (combination-fun call))
+ (eq (lvar-fun-name (combination-fun call))
(leaf-source-name funleaf))
(let ((info (basic-combination-kind call)))
(not (or (fun-info-ir2-convert info)
~_policy=~S ~_arg types=~S~:>"
(lexenv-policy (node-lexenv call))
(mapcar (lambda (arg)
- (type-specifier (continuation-type arg)))
+ (type-specifier (lvar-type arg)))
args))))
(ltn-default-call call)
(return-from ltn-analyze-known-call (values)))
(setf (node-tail-p call) nil)
(dolist (arg args)
- (annotate-1-value-continuation arg))))
+ (annotate-1-value-lvar arg))))
(values))
-;;; CASTs are merely continuation annotations than nodes. So we wait
-;;; until value consumer deside how values should be passed, and after
-;;; that we propagate this decision backwards through CAST chain. The
+;;; CASTs are merely lvar annotations than nodes. So we wait until
+;;; value consumer deside how values should be passed, and after that
+;;; we propagate this decision backwards through CAST chain. The
;;; exception is a dangling CAST with a type check, which we process
;;; immediately.
(defun ltn-analyze-cast (cast)
(declare (type cast cast))
(setf (node-tail-p cast) nil)
(when (and (cast-type-check cast)
- (not (continuation-dest (node-cont cast))))
+ (not (node-lvar cast)))
;; FIXME
(bug "IR2 type checking of unused values in not implemented.")
)
(values))
-(defun ltn-annotate-casts (cont)
- (declare (type continuation cont))
- (do-uses (node cont)
+(defun ltn-annotate-casts (lvar)
+ (declare (type lvar lvar))
+ (do-uses (node lvar)
(when (cast-p node)
(ltn-annotate-cast node))))
(defun ltn-annotate-cast (cast)
(declare (type cast))
- (let ((2cont (continuation-info (node-cont cast)))
+ (let ((2lvar (lvar-info (node-lvar cast)))
(value (cast-value cast)))
- (aver 2cont)
+ (aver 2lvar)
;; XXX
- (ecase (ir2-continuation-kind 2cont)
+ (ecase (ir2-lvar-kind 2lvar)
(:unknown
- (annotate-unknown-values-continuation value))
+ (annotate-unknown-values-lvar value))
(:fixed
- (let* ((count (length (ir2-continuation-locs 2cont)))
- (ctype (continuation-derived-type value)))
+ (let* ((count (length (ir2-lvar-locs 2lvar)))
+ (ctype (lvar-derived-type value)))
(multiple-value-bind (types rest)
(values-type-types ctype (specifier-type 'null))
- (annotate-fixed-values-continuation
+ (annotate-fixed-values-lvar
value
(mapcar #'primitive-type
(adjust-list types count rest))))))))
;;; block can be split out from underneath us, and DO-NODES would scan
;;; past the block end in that case.
(defun ltn-analyze-block (block)
- (do* ((node (continuation-next (block-start block))
- (continuation-next cont))
- (cont (node-cont node) (node-cont node)))
+ (do* ((node (block-start-node block)
+ (ctran-next ctran))
+ (ctran (node-next node) (node-next node)))
(nil)
- (let ((dest (continuation-dest cont)))
+ (let* ((lvar (when (valued-node-p node)
+ (node-lvar node)))
+ (dest (and lvar (lvar-dest lvar))))
(when (and (cast-p dest)
(not (cast-type-check dest))
- (immediately-used-p cont node))
+ (immediately-used-p lvar node))
(derive-node-type node (cast-asserted-type dest))))
(etypecase node
(ref)
;;; whether there are any unknown values receivers, making notations
;;; in the components' GENERATORS and RECEIVERS as appropriate.
;;;
-;;; If any unknown-values continations are received by this block (as
+;;; If any unknown-values lvars are received by this block (as
;;; indicated by IR2-BLOCK-POPPED), then we add the block to the
;;; IR2-COMPONENT-VALUES-RECEIVERS.
;;;
(defknown %load-time-value (t) t (flushable movable))
-(def-ir1-translator load-time-value ((form &optional read-only-p) start cont)
+(def-ir1-translator load-time-value
+ ((form &optional read-only-p) start next result)
#!+sb-doc
"Arrange for FORM to be evaluated at load-time and use the value produced
as if it were a constant. If READ-ONLY-P is non-NIL, then the resultant
form
`(make-value-cell ,form)))
(declare (ignore type))
- (ir1-convert start cont
+ (ir1-convert start next result
(if read-only-p
`(%load-time-value ',handle)
`(value-cell-ref (%load-time-value ',handle)))))
(error (condition)
(compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
condition)))))
- (ir1-convert start cont
+ (ir1-convert start next result
(if read-only-p
`',value
`(value-cell-ref ',(make-value-cell value)))))))
(defoptimizer (%load-time-value ir2-convert) ((handle) node block)
- (aver (constant-continuation-p handle))
- (let ((cont (node-cont node))
- (tn (make-load-time-value-tn (continuation-value handle)
+ (aver (constant-lvar-p handle))
+ (let ((lvar (node-lvar node))
+ (tn (make-load-time-value-tn (lvar-value handle)
*universal-type*)))
- (move-continuation-result node block (list tn) cont)))
+ (move-lvar-result node block (list tn) lvar)))
;;; START-VAR and CONT-VAR are bound to the start and result
;;; continuations for the resulting IR1. KIND is the function kind to
;;; associate with NAME.
-(defmacro def-ir1-translator (name (lambda-list start-var cont-var
+(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var
&key (kind :special-form))
&body body)
(let ((fn-name (symbolicate "IR1-CONVERT-" name))
:error-fun 'convert-condition-into-compiler-error
:wrap-block nil)
`(progn
- (declaim (ftype (function (continuation continuation t) (values))
+ (declaim (ftype (function (ctran ctran (or lvar null) t) (values))
,fn-name))
- (defun ,fn-name (,start-var ,cont-var ,n-form)
+ (defun ,fn-name (,start-var ,next-var ,result-var ,n-form)
(let ((,n-env *lexenv*))
,@decls
,body
(let* ((var (if (atom spec) spec (first spec)))
(key (keywordicate var)))
(vars var)
- (binds `(,var (find-keyword-continuation ,n-keys ,key)))
+ (binds `(,var (find-keyword-lvar ,n-keys ,key)))
(keywords key))
(let* ((head (first spec))
(var (second head))
(key (first head)))
(vars var)
- (binds `(,var (find-keyword-continuation ,n-keys ,key)))
+ (binds `(,var (find-keyword-lvar ,n-keys ,key)))
(keywords key))))
(let ((n-length (gensym))
`((,n-node)
(let* ((,n-args (basic-combination-args ,n-node))
,@(when result
- `((,result (node-cont ,n-node)))))
+ `((,result (node-lvar ,n-node)))))
(multiple-value-bind (,n-lambda ,n-decls)
,parsed-form
(if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
;;; successively.
;;;
;;; XXX Could change it not to replicate the code someday perhaps...
-(defmacro do-uses ((node-var continuation &optional result) &body body)
- (once-only ((n-cont continuation))
- `(ecase (continuation-kind ,n-cont)
- (:unused)
- (:inside-block
- (block nil
- (let ((,node-var (continuation-use ,n-cont)))
- ,@body
- ,result)))
- ((:block-start :deleted-block-start)
- (dolist (,node-var (block-start-uses (continuation-block ,n-cont))
- ,result)
- ,@body)))))
+(defmacro do-uses ((node-var lvar &optional result) &body body)
+ (with-unique-names (uses)
+ `(let ((,uses (lvar-uses ,lvar)))
+ (if (listp ,uses)
+ (dolist (,node-var ,uses ,result)
+ ,@body)
+ (block nil
+ (let ((,node-var ,uses))
+ ,@body))))))
;;; Iterate over the nodes in BLOCK, binding NODE-VAR to the each node
;;; and CONT-VAR to the node's CONT. The only keyword option is
;;; the block start is deleted, we just punt. With RESTART-P, we are
;;; also more careful about termination, re-indirecting the BLOCK-LAST
;;; each time.
-(defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)
- (let ((n-block (gensym))
- (n-last-cont (gensym)))
- `(let* ((,n-block ,block)
- ,@(unless restart-p
- `((,n-last-cont (node-cont (block-last ,n-block))))))
- (do* ((,node-var (continuation-next (block-start ,n-block))
- ,(if restart-p
- `(cond
- ((eq (continuation-block ,cont-var) ,n-block)
- (aver (continuation-next ,cont-var))
- (continuation-next ,cont-var))
- (t
- (let ((start (block-start ,n-block)))
- (unless (eq (continuation-kind start)
- :block-start)
- (return nil))
- (continuation-next start))))
- `(continuation-next ,cont-var)))
- (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
- (())
- (declare (type node ,node-var))
- ,@body
- (when ,(if restart-p
- `(or (eq ,node-var (block-last ,n-block))
- (eq ,cont-var (node-cont (block-last ,n-block)))
- (block-delete-p ,n-block))
- `(eq ,cont-var ,n-last-cont))
- (return nil))))))
+(defmacro do-nodes ((node-var lvar-var block &key restart-p)
+ &body body)
+ (with-unique-names (n-block n-start)
+ `(do* ((,n-block ,block)
+ (,n-start (block-start ,n-block))
+
+ (,node-var (ctran-next ,n-start)
+ ,(if restart-p
+ `(let ((next (node-next ,node-var)))
+ (cond
+ ((not next)
+ (return))
+ ((eq (ctran-block next) ,n-block)
+ (ctran-next next))
+ (t
+ (let ((start (block-start ,n-block)))
+ (unless (eq (ctran-kind start)
+ :block-start)
+ (return nil))
+ (ctran-next start)))))
+ `(acond ((node-next ,node-var)
+ (ctran-next it))
+ (t (return)))))
+ ,@(when lvar-var
+ `((,lvar-var #1=(when (valued-node-p ,node-var)
+ (node-lvar ,node-var))
+ #1#))))
+ (nil)
+ ,@body
+ ,@(when restart-p
+ `((when (block-delete-p ,n-block)
+ (return)))))))
+
;;; like DO-NODES, only iterating in reverse order
-(defmacro do-nodes-backwards ((node-var cont-var block) &body body)
+(defmacro do-nodes-backwards ((node-var lvar block) &body body)
(let ((n-block (gensym))
(n-start (gensym))
- (n-last (gensym))
- (n-next (gensym)))
- `(let* ((,n-block ,block)
- (,n-start (block-start ,n-block))
- (,n-last (block-last ,n-block)))
- (do* ((,cont-var (node-cont ,n-last) ,n-next)
- (,node-var ,n-last (continuation-use ,cont-var))
- (,n-next (node-prev ,node-var) (node-prev ,node-var)))
- (())
- ,@body
- (when (eq ,n-next ,n-start)
- (return nil))))))
-
-(defmacro do-nodes-carefully ((node-var cont-var block) &body body)
- (with-unique-names (n-block n-last)
+ (n-prev (gensym)))
+ `(do* ((,n-block ,block)
+ (,n-start (block-start ,n-block))
+ (,node-var (block-last ,n-block) (ctran-use ,n-prev))
+ (,n-prev (node-prev ,node-var) (node-prev ,node-var))
+ (,lvar #1=(when (valued-node-p ,node-var) (node-lvar ,node-var))
+ #1#))
+ (nil)
+ ,@body
+ (when (eq ,n-prev ,n-start)
+ (return nil)))))
+
+(defmacro do-nodes-carefully ((node-var block) &body body)
+ (with-unique-names (n-block n-ctran)
`(loop with ,n-block = ,block
- with ,n-last = (block-last ,n-block)
- for ,cont-var = (block-start ,n-block) then (node-cont ,node-var)
- for ,node-var = (and ,cont-var (continuation-next ,cont-var))
+ for ,n-ctran = (block-start ,n-block) then (node-next ,node-var)
+ for ,node-var = (and ,n-ctran (ctran-next ,n-ctran))
while ,node-var
- do (progn ,@body)
- until (eq ,node-var ,n-last))))
+ do (progn ,@body))))
;;; Bind the IR1 context variables to the values associated with NODE,
;;; so that new, extra IR1 conversion related to NODE can be done
(namestring input-pathname))))
(when trace-file
(let* ((default-trace-file-pathname
- (make-pathname :type "trace" :defaults input-pathname))
+ (make-pathname :type "ntrace" :defaults input-pathname))
(trace-file-pathname
(if (eql trace-file t)
default-trace-file-pathname
;;; continuation represents both, but the continuation can represent
;;; the case of a discarded result by having no DEST.
-(def!struct (continuation
+(def!struct (ctran
(:make-load-form-fun ignore-it)
- (:constructor make-continuation (&optional dest)))
+ (:constructor make-ctran))
;; an indication of the way that this continuation is currently used
;;
;; :UNUSED
;; continuations. NEXT can have a non-null value if the next node
;; has already been determined.
;;
- ;; :DELETED
- ;; A continuation that has been deleted from IR1. Any pointers into
- ;; IR1 are cleared. There are two conditions under which a deleted
- ;; continuation may appear in code:
- ;; -- The CONT of the LAST node in a block may be a deleted
- ;; continuation when the original receiver of the continuation's
- ;; value was deleted. Note that DEST in a deleted continuation is
- ;; null, so it is easy to know not to attempt delivering any
- ;; values to the continuation.
- ;; -- Unreachable code that hasn't been deleted yet may receive
- ;; deleted continuations. All such code will be in blocks that
- ;; have DELETE-P set. All unreachable code is deleted by control
- ;; optimization, so the backend doesn't have to worry about this.
- ;;
;; :BLOCK-START
;; The continuation that is the START of BLOCK. This is the only kind
;; of continuation that can have more than one use. The BLOCK's
;; START-USES is a list of all the uses.
;;
- ;; :DELETED-BLOCK-START
- ;; Like :BLOCK-START, but BLOCK has been deleted. A block
- ;; starting continuation is made into a deleted block start when
- ;; the block is deleted, but the continuation still may have
- ;; value semantics. Since there isn't any code left, next is
- ;; null.
- ;;
;; :INSIDE-BLOCK
- ;; A continuation that is the CONT of some node in BLOCK.
- (kind :unused :type (member :unused :deleted :inside-block :block-start
- :deleted-block-start))
- ;; The node which receives this value, if any. In a deleted
- ;; continuation, this is null even though the node that receives
- ;; this continuation may not yet be deleted.
- (dest nil :type (or node null))
+ ;; A continuation that is the NEXT of some node in BLOCK.
+ (kind :unused :type (member :unused :inside-block :block-start))
;; If this is a NODE, then it is the node which is to be evaluated
;; next. This is always null in :DELETED and :UNUSED continuations,
;; and will be null in a :INSIDE-BLOCK continuation when this is the
;; CONT of the LAST.
(next nil :type (or node null))
+ ;; the node where this CTRAN is used, if unique. This is always null
+ ;; in :DELETED, :UNUSED and :BLOCK-START CTRANs, and is never null
+ ;; in :INSIDE-BLOCK continuations.
+ (use nil :type (or node null))
+ ;; the basic block this continuation is in. This is null only in
+ ;; :DELETED and :UNUSED continuations. Note that blocks that are
+ ;; unreachable but still in the DFO may receive deleted
+ ;; continuations, so it isn't o.k. to assume that any continuation
+ ;; that you pick up out of its DEST node has a BLOCK.
+ (block nil :type (or cblock null))
+ ;; something or other that the back end annotates this continuation with
+ (info nil))
+
+(def!struct (lvar
+ (:make-load-form-fun ignore-it)
+ (:constructor make-lvar (&optional dest)))
+ ;; The node which receives this value. NIL only temporarily.
+ (dest nil :type (or node null))
;; cached type of this continuation's value. If NIL, then this must
;; be recomputed: see CONTINUATION-DERIVED-TYPE.
(%derived-type nil :type (or ctype null))
;; :INSIDE-BLOCK continuations. In a :BLOCK-START continuation, the
;; BLOCK's START-USES indicate whether NIL means no uses or more
;; than one use.
- (use nil :type (or node null))
- ;; the basic block this continuation is in. This is null only in
- ;; :DELETED and :UNUSED continuations. Note that blocks that are
- ;; unreachable but still in the DFO may receive deleted
- ;; continuations, so it isn't o.k. to assume that any continuation
- ;; that you pick up out of its DEST node has a BLOCK.
- (block nil :type (or cblock null))
+ (uses nil :type (or node list))
;; set to true when something about this continuation's value has
;; changed. See REOPTIMIZE-CONTINUATION. This provides a way for IR1
;; optimize to determine which operands to a node have changed. If
;; recomputed: see CONTINUATION-EXTERNALLY-CHECKABLE-TYPE.
(%externally-checkable-type nil :type (or null ctype))
;; something or other that the back end annotates this continuation with
- (info nil)
- ;; uses of this continuation in the lexical environment. They are
- ;; recorded so that when one continuation is substituted for another
- ;; the environment may be updated properly.
- (lexenv-uses nil :type list))
+ (info nil))
+#+nil
(def!method print-object ((x continuation) stream)
(print-unreadable-object (x stream :type t :identity t)
(format stream " #~D" (cont-num x))))
(:copier nil))
;; unique ID for debugging
#!+sb-show (id (new-object-id) :read-only t)
- ;; the bottom-up derived type for this node.
- (derived-type *wild-type* :type ctype)
;; True if this node needs to be optimized. This is set to true
;; whenever something changes about the value of a continuation
;; whose DEST is this node.
;; the continuation which receives the value of this node. This also
;; indicates what we do controlwise after evaluating this node. This
;; may be null during IR1 conversion.
- (cont nil :type (or continuation null))
+ (next nil :type (or ctran null))
;; the continuation that this node is the NEXT of. This is null
;; during IR1 conversion when we haven't linked the node in yet or
;; in nodes that have been deleted from the IR1 by UNLINK-NODE.
- (prev nil :type (or continuation null))
+ (prev nil :type (or ctran null))
;; the lexical environment this node was converted in
(lexenv *lexenv* :type lexenv)
;; a representation of the source code responsible for generating
;; can null out this slot.
(tail-p nil :type boolean))
+(defstruct (valued-node (:conc-name node-)
+ (:include node)
+ (:constructor nil)
+ (:copier nil))
+ ;; the bottom-up derived type for this node.
+ (derived-type *wild-type* :type ctype)
+ ;; may be NIL if the value is unused.
+ (lvar nil :type (or lvar null)))
+
;;; Flags that are used to indicate various things about a block, such
;;; as what optimizations need to be done on it:
;;; -- REOPTIMIZE is set when something interesting happens the uses of a
-;;; continuation whose DEST is in this block. This indicates that the
+;;; lvar whose DEST is in this block. This indicates that the
;;; value-driven (forward) IR1 optimizations should be done on this block.
;;; -- FLUSH-P is set when code in this block becomes potentially flushable,
;;; usually due to a continuation's DEST becoming null.
(:constructor make-block (start))
(:constructor make-block-key)
(:conc-name block-)
- (:predicate block-p)
- (:copier copy-block))
+ (:predicate block-p))
;; a list of all the blocks that are predecessors/successors of this
;; block. In well-formed IR1, most blocks will have one successor.
;; The only exceptions are:
;; 3. blocks with DELETE-P set (zero)
(pred nil :type list)
(succ nil :type list)
- ;; the continuation which heads this block (either a :BLOCK-START or
+ ;; the ctran which heads this block (either a :BLOCK-START or
;; :DELETED-BLOCK-START), or NIL when we haven't made the start
- ;; continuation yet (and in the dummy component head and tail
+ ;; ctran yet (and in the dummy component head and tail
;; blocks)
- (start nil :type (or continuation null))
- ;; a list of all the nodes that have START as their CONT
- (start-uses nil :type list)
+ (start nil :type (or ctran null))
;; the last node in this block. This is NIL when we are in the
;; process of building a block (and in the dummy component head and
;; tail blocks.)
(defstruct (physenv (:copier nil))
;; the function that allocates this physical environment
(lambda (missing-arg) :type clambda :read-only t)
- #| ; seems not to be used as of sbcl-0.pre7.51
- ;; a list of all the lambdas that allocate variables in this
- ;; physical environment
- (lambdas nil :type list)
- |#
;; This ultimately converges to a list of all the LAMBDA-VARs and
;; NLX-INFOs needed from enclosing environments by code in this
;; physical environment. In the meantime, it may be
;;; An NLX-INFO structure is used to collect various information about
;;; non-local exits. This is effectively an annotation on the
-;;; CONTINUATION, although it is accessed by searching in the
+;;; continuation, although it is accessed by searching in the
;;; PHYSENV-NLX-INFO.
-(def!struct (nlx-info (:make-load-form-fun ignore-it))
+(def!struct (nlx-info (:constructor make-nlx-info
+ (cleanup exit &aux (lvar (node-lvar exit))))
+ (:make-load-form-fun ignore-it))
;; the cleanup associated with this exit. In a catch or
;; unwind-protect, this is the :CATCH or :UNWIND-PROTECT cleanup,
;; and not the cleanup for the escape block. The CLEANUP-KIND of
;; For this purpose, the ENTRY must also be used to disambiguate,
;; since exits to different places may deliver their result to the
;; same continuation.
- (continuation (missing-arg) :type continuation)
+ (exit (missing-arg) :type exit)
+ (lvar (missing-arg) :type (or lvar null))
;; the entry stub inserted by physical environment analysis. This is
;; a block containing a call to the %NLX-ENTRY funny function that
;; has the original exit destination as its successor. Null only
;; some kind of info used by the back end
info)
(defprinter (nlx-info :identity t)
- continuation
+ exit
target
info)
\f
;;; end must check for and ignore unreferenced variables. Note that a
;;; deleted LAMBDA-VAR may have sets; in this case the back end is
;;; still responsible for propagating the SET-VALUE to the set's CONT.
-(def!struct (lambda-var (:include basic-var))
+(!def-boolean-attribute lambda-var
;; true if this variable has been declared IGNORE
- (ignorep nil :type boolean)
- ;; the CLAMBDA that this var belongs to. This may be null when we are
- ;; building a lambda during IR1 conversion.
- (home nil :type (or null clambda))
+ ignore
;; This is set by physical environment analysis if it chooses an
;; indirect (value cell) representation for this variable because it
;; is both set and closed over.
- (indirect nil :type boolean)
+ indirect)
+
+(def!struct (lambda-var (:include basic-var))
+ (flags (lambda-var-attributes)
+ :type attributes)
+ ;; the CLAMBDA that this var belongs to. This may be null when we are
+ ;; building a lambda during IR1 conversion.
+ (home nil :type (or null clambda))
;; The following two slots are only meaningful during IR1 conversion
;; of hairy lambda vars:
;;
#!+sb-show id
(type :test (not (eq type *universal-type*)))
(where-from :test (not (eq where-from :assumed)))
- (ignorep :test ignorep)
+ (flags :test (not (zerop flags))
+ :prin1 (decode-lambda-var-attributes flags))
(arg-info :test arg-info)
(specvar :test specvar))
+
+(defmacro lambda-var-ignorep (var)
+ `(lambda-var-attributep (lambda-var-flags ,var) ignore))
+(defmacro lambda-var-indirect (var)
+ `(lambda-var-attributep (lambda-var-flags ,var) indirect))
\f
;;;; basic node types
;;; A REF represents a reference to a LEAF. REF-REOPTIMIZE is
;;; initially (and forever) NIL, since REFs don't receive any values
;;; and don't have any IR1 optimizer.
-(defstruct (ref (:include node (reoptimize nil))
+(defstruct (ref (:include valued-node (reoptimize nil))
(:constructor make-ref
(leaf
&aux (leaf-type (leaf-type leaf))
(:predicate if-p)
(:constructor make-if)
(:copier copy-if))
- ;; CONTINUATION for the predicate
- (test (missing-arg) :type continuation)
+ ;; LVAR for the predicate
+ (test (missing-arg) :type lvar)
;; the blocks that we execute next in true and false case,
;; respectively (may be the same)
(consequent (missing-arg) :type cblock)
(alternative (missing-arg) :type cblock))
(defprinter (cif :conc-name if- :identity t)
- (test :prin1 (continuation-use test))
+ (test :prin1 (lvar-uses test))
consequent
alternative)
-(defstruct (cset (:include node
+(defstruct (cset (:include valued-node
(derived-type (make-single-value-type
*universal-type*)))
(:conc-name set-)
(:copier copy-set))
;; descriptor for the variable set
(var (missing-arg) :type basic-var)
- ;; continuation for the value form
- (value (missing-arg) :type continuation))
+ ;; LVAR for the value form
+ (value (missing-arg) :type lvar))
(defprinter (cset :conc-name set- :identity t)
var
- (value :prin1 (continuation-use value)))
+ (value :prin1 (lvar-uses value)))
;;; The BASIC-COMBINATION structure is used to represent both normal
-;;; and multiple value combinations. In a local function call, this
+;;; and multiple value combinations. In a let-like function call, this
;;; node appears at the end of its block and the body of the called
;;; function appears as the successor. The NODE-CONT remains the
-;;; continuation which receives the value of the call.
-(defstruct (basic-combination (:include node)
+;;; continuation which receives the value of the call. XXX
+(defstruct (basic-combination (:include valued-node)
(:constructor nil)
(:copier nil))
- ;; continuation for the function
- (fun (missing-arg) :type continuation)
- ;; list of CONTINUATIONs for the args. In a local call, an argument
- ;; continuation may be replaced with NIL to indicate that the
- ;; corresponding variable is unreferenced, and thus no argument
- ;; value need be passed.
+ ;; LVAR for the function
+ (fun (missing-arg) :type lvar)
+ ;; list of LVARs for the args. In a local call, an argument lvar may
+ ;; be replaced with NIL to indicate that the corresponding variable
+ ;; is unreferenced, and thus no argument value need be passed.
(args nil :type list)
;; the kind of function call being made. :LOCAL means that this is a
;; local call to a function in the same component, and that argument
(:copier nil)))
(defprinter (combination :identity t)
#!+sb-show id
- (fun :prin1 (continuation-use fun))
+ (fun :prin1 (lvar-uses fun))
(args :prin1 (mapcar (lambda (x)
(if x
- (continuation-use x)
+ (lvar-uses x)
"<deleted>"))
args)))
(:constructor make-mv-combination (fun))
(:copier nil)))
(defprinter (mv-combination)
- (fun :prin1 (continuation-use fun))
- (args :prin1 (mapcar #'continuation-use args)))
+ (fun :prin1 (lvar-uses fun))
+ (args :prin1 (mapcar #'lvar-uses args)))
;;; The BIND node marks the beginning of a lambda body and represents
;;; the creation and initialization of the variables.
;; the lambda we are returning from. Null temporarily during
;; ir1tran.
(lambda nil :type (or clambda null))
- ;; the continuation which yields the value of the lambda
- (result (missing-arg) :type continuation)
+ ;; the lvar which yields the value of the lambda
+ (result (missing-arg) :type lvar)
;; the union of the node-derived-type of all uses of the result
;; other than by a local call, intersected with the result's
;; asserted-type. If there are no non-call uses, this is
;;; The CAST node represents type assertions. The check for
;;; TYPE-TO-CHECK is performed and then the VALUE is declared to be of
;;; type ASSERTED-TYPE.
-(defstruct (cast (:include node)
+(defstruct (cast (:include valued-node)
(:constructor %make-cast))
(asserted-type (missing-arg) :type ctype)
(type-to-check (missing-arg) :type ctype)
;; T
;; A type check is needed.
(%type-check t :type (member t nil))
- ;; the continuations which is checked
- (value (missing-arg) :type continuation))
+ ;; the lvar which is checked
+ (value (missing-arg) :type lvar))
(defprinter (cast :identity t)
%type-check
value
;;; the returned value being delivered directly to the exit
;;; continuation, it is delivered to our VALUE continuation. The
;;; original exit continuation is the exit node's CONT.
-(defstruct (exit (:include node)
+(defstruct (exit (:include valued-node)
(:copier nil))
;; the ENTRY node that this is an exit for. If null, this is a
;; degenerate exit. A degenerate exit is used to "fill" an empty
;; block (which isn't allowed in IR1.) In a degenerate exit, Value
;; is always also null.
(entry nil :type (or entry null))
- ;; the continuation yielding the value we are to exit with. If NIL,
- ;; then no value is desired (as in GO).
- (value nil :type (or continuation null)))
+ ;; the lvar yielding the value we are to exit with. If NIL, then no
+ ;; value is desired (as in GO).
+ (value nil :type (or lvar null)))
(defprinter (exit :identity t)
#!+sb-show id
(entry :test entry)
;;;; Freeze some structure types to speed type testing.
#!-sb-fluid
-(declaim (freeze-type node leaf lexenv continuation cblock component cleanup
+(declaim (freeze-type node leaf lexenv ctran lvar cblock component cleanup
physenv tail-set nlx-info))
(functional-has-external-references-p fun))
(aver (member kind '(:optional :cleanup :escape)))
(setf (functional-kind fun) nil)
- (delete-functional fun)))))
+ (delete-functional fun)))))
(values))
(declare (type physenv env) (type exit exit))
(let* ((exit-block (node-block exit))
(next-block (first (block-succ exit-block)))
- (cleanup (entry-cleanup (exit-entry exit)))
- (info (make-nlx-info :cleanup cleanup
- :continuation (node-cont exit)))
(entry (exit-entry exit))
+ (cleanup (entry-cleanup entry))
+ (info (make-nlx-info cleanup exit))
(new-block (insert-cleanup-code exit-block next-block
entry
`(%nlx-entry ',info)
- (entry-cleanup entry)))
+ cleanup))
(component (block-component new-block)))
(unlink-blocks exit-block new-block)
(link-blocks exit-block (component-tail component))
;;; the NLX use.
(defun note-non-local-exit (env exit)
(declare (type physenv env) (type exit exit))
- (let ((entry (exit-entry exit))
- (cont (node-cont exit))
+ (let ((lvar (node-lvar exit))
(exit-fun (node-home-lambda exit)))
- (if (find-nlx-info entry cont)
+ (if (find-nlx-info exit)
(let ((block (node-block exit)))
(aver (= (length (block-succ block)) 1))
(unlink-blocks block (first (block-succ block)))
(link-blocks block (component-tail (block-component block))))
(insert-nlx-entry-stub exit env))
- (let ((info (find-nlx-info entry cont)))
+ (let ((info (find-nlx-info exit)))
(aver info)
(close-over info (node-physenv exit) env)
(when (eq (functional-kind exit-fun) :escape)
(leaf-refs exit-fun))
(substitute-leaf (find-constant info) exit-fun)
(let ((node (block-last (nlx-info-target info))))
- (delete-continuation-use node)
- (add-continuation-use node (nlx-info-continuation info))))))
+ (delete-lvar-use node)
+ (aver (eq lvar (node-lvar exit)))
+ (add-lvar-use node lvar)))))
(values))
;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT
(basic-combination-args node))))
(ecase (cleanup-kind cleanup)
(:special-bind
- (code `(%special-unbind ',(continuation-value (first args)))))
+ (code `(%special-unbind ',(lvar-value (first args)))))
(:catch
(code `(%catch-breakup)))
(:unwind-protect
(code `(%unwind-protect-breakup))
- (let ((fun (ref-leaf (continuation-use (second args)))))
+ (let ((fun (ref-leaf (lvar-uses (second args)))))
(reanalyze-funs fun)
(code `(%funcall ,fun))))
((:block :tagbody)
(let ((result (return-result ret)))
(do-uses (use result)
(when (and (policy use merge-tail-calls)
+ (basic-combination-p use)
(immediately-used-p result use)
(or (not (eq (node-derived-type use) *empty-type*))
- (not (basic-combination-p use))
(eq (basic-combination-kind use) :local)))
(setf (node-tail-p use) t)))))))
(values))
((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
(unsigned-byte 32))
"recode as shifts and adds"
- (let ((y (continuation-value y)))
+ (let ((y (lvar-value y)))
(multiple-value-bind (result adds shifts)
(ub32-strength-reduce-constant-multiply 'x y)
(cond
#!+darwin
(deftransform %alien-funcall ((function type &rest args))
- (assert (sb!c::constant-continuation-p type))
- (let* ((type (sb!c::continuation-value type))
+ (assert (sb!c::constant-lvar-p type))
+ (let* ((type (sb!c::lvar-value type))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(assert (= (length arg-types) (length args)))
;;;; transforms for optimizing SAP+
(deftransform sap+ ((sap offset))
- (cond ((and (constant-continuation-p offset)
- (eql (continuation-value offset) 0))
+ (cond ((and (constant-lvar-p offset)
+ (eql (lvar-value offset) 0))
'sap)
(t
(extract-fun-args sap 'sap+ 2)
(deftransform map ((result-type-arg fun seq &rest seqs) * * :node node)
(let* ((seq-names (make-gensym-list (1+ (length seqs))))
(bare `(%map result-type-arg fun ,@seq-names))
- (constant-result-type-arg-p (constant-continuation-p result-type-arg))
+ (constant-result-type-arg-p (constant-lvar-p result-type-arg))
;; what we know about the type of the result. (Note that the
;; "result type" argument is not necessarily the type of the
;; result, since NIL means the result has NULL type.)
(result-type (if (not constant-result-type-arg-p)
'consed-sequence
(let ((result-type-arg-value
- (continuation-value result-type-arg)))
+ (lvar-value result-type-arg)))
(if (null result-type-arg-value)
'null
result-type-arg-value)))))
(bindings `(index 0 (1+ index)))
(declarations `(type index index)))
(vector-lengths length)))
- (loop for seq of-type continuation in seqs
+ (loop for seq of-type lvar in seqs
for seq-name in seq-names
- for type = (continuation-type seq)
+ for type = (lvar-type seq)
do (cond ((csubtypep type (specifier-type 'list))
(with-unique-names (index)
(bindings `(,index ,seq-name (cdr ,index)))
(deftransform %map ((result-type fun seq &rest seqs) * *
:policy (>= speed space))
"open code"
- (unless (constant-continuation-p result-type)
+ (unless (constant-lvar-p result-type)
(give-up-ir1-transform "RESULT-TYPE argument not constant"))
(labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
(fn-1subtypep (fn x y)
(give-up-ir1-transform
"can't analyze sequence type relationship"))))
(1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y)))
- (let* ((result-type-value (continuation-value result-type))
+ (let* ((result-type-value (lvar-value result-type))
(result-supertype (cond ((null result-type-value) 'null)
((1subtypep result-type-value 'vector)
'vector)
(macrolet ((def (name)
`(deftransform ,name ((e l &key (test #'eql)) * *
:node node)
- (unless (constant-continuation-p l)
+ (unless (constant-lvar-p l)
(give-up-ir1-transform))
- (let ((val (continuation-value l)))
+ (let ((val (lvar-value l)))
(unless (policy node
(or (= speed 3)
(and (>= speed space)
;; if ITEM is not a NUMBER or is a FIXNUM, apply
;; transform, else give up on transform.
(cond (test
- (unless (continuation-fun-is test '(eq))
+ (unless (lvar-fun-is test '(eq))
(give-up-ir1-transform)))
- ((types-equal-or-intersect (continuation-type item)
+ ((types-equal-or-intersect (lvar-type item)
(specifier-type 'number))
(give-up-ir1-transform "Item might be a number.")))
`(,',eq-fun item list))))
;;; Return true if CONT's only use is a non-NOTINLINE reference to a
;;; global function with one of the specified NAMES.
-(defun continuation-fun-is (cont names)
- (declare (type continuation cont) (list names))
- (let ((use (continuation-use cont)))
+(defun lvar-fun-is (lvar names)
+ (declare (type lvar lvar) (list names))
+ (let ((use (lvar-uses lvar)))
(and (ref-p use)
(let ((leaf (ref-leaf use)))
(and (global-var-p leaf)
;;; IR1 transform.
;;;
;;; ### Probably should take an ARG and flame using the NAME.
-(defun constant-value-or-lose (cont &optional default)
- (declare (type (or continuation null) cont))
- (cond ((not cont) default)
- ((constant-continuation-p cont)
- (continuation-value cont))
+(defun constant-value-or-lose (lvar &optional default)
+ (declare (type (or lvar null) lvar))
+ (cond ((not lvar) default)
+ ((constant-lvar-p lvar)
+ (lvar-value lvar))
(t
(give-up-ir1-transform))))
;;;; CONS accessor DERIVE-TYPE optimizers
(defoptimizer (car derive-type) ((cons))
- (let ((type (continuation-type cons))
+ (let ((type (lvar-type cons))
(null-type (specifier-type 'null)))
(cond ((eq type null-type)
null-type)
(cons-type-car-type type)))))
(defoptimizer (cdr derive-type) ((cons))
- (let ((type (continuation-type cons))
+ (let ((type (lvar-type cons))
(null-type (specifier-type 'null)))
(cond ((eq type null-type)
null-type)
;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
;;; expansion, so we factor out the condition into this function.
(defun check-inlineability-of-find-position-if (sequence from-end)
- (let ((ctype (continuation-type sequence)))
+ (let ((ctype (lvar-type sequence)))
(cond ((csubtypep ctype (specifier-type 'vector))
;; It's not worth trying to inline vector code unless we
;; know a fair amount about it at compile time.
(upgraded-element-type-specifier-or-give-up sequence)
- (unless (constant-continuation-p from-end)
+ (unless (constant-lvar-p from-end)
(give-up-ir1-transform
"FROM-END argument value not known at compile time")))
((csubtypep ctype (specifier-type 'list))
(incf index))))))
(def %find-position-if when)
(def %find-position-if-not unless))
-
+
;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
;;; without loss of efficiency. (I.e., the optimizer should be able
;;; to straighten everything out.)
((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
(unsigned-byte 32))
"recode as shifts and adds"
- (let ((y (continuation-value y)))
+ (let ((y (lvar-value y)))
(multiple-value-bind (result adds shifts)
(ub32-strength-reduce-constant-multiply 'x y)
(cond
;; instead of calling the inline ASH which has to check for the
;; direction of the shift at run-time.
(deftransform ash ((num shift) (integer integer))
- (let ((num-type (continuation-type num))
- (shift-type (continuation-type shift)))
+ (let ((num-type (lvar-type num))
+ (shift-type (lvar-type shift)))
;; Can only handle right shifts
(unless (csubtypep shift-type (specifier-type '(integer * 0)))
(give-up-ir1-transform))
(make-result-state))))))
(deftransform %alien-funcall ((function type &rest args))
- (assert (sb!c::constant-continuation-p type))
- (let* ((type (sb!c::continuation-value type))
+ (assert (sb!c::constant-lvar-p type))
+ (let* ((type (sb!c::lvar-value type))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(assert (= (length arg-types) (length args)))
(multiple-value-bind (definitely-< definitely->=)
(ir1-transform-<-helper x y)
(cond (definitely-<
- (continuation-type y))
+ (lvar-type y))
(definitely->=
- (continuation-type x))
+ (lvar-type x))
(t
- (make-canonical-union-type (list (continuation-type x)
- (continuation-type y)))))))
+ (make-canonical-union-type (list (lvar-type x)
+ (lvar-type y)))))))
(defoptimizer (min derive-type) ((x y))
(multiple-value-bind (definitely-< definitely->=)
(ir1-transform-<-helper x y)
(cond (definitely-<
- (continuation-type x))
+ (lvar-type x))
(definitely->=
- (continuation-type y))
+ (lvar-type y))
(t
- (make-canonical-union-type (list (continuation-type x)
- (continuation-type y)))))))
+ (make-canonical-union-type (list (lvar-type x)
+ (lvar-type y)))))))
(deftransform max ((x y) (number number) *)
- (let ((x-type (continuation-type x))
- (y-type (continuation-type y))
+ (let ((x-type (lvar-type x))
+ (y-type (lvar-type y))
(signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
(unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
(d-float (specifier-type 'double-float))
,arg1 ,arg2)))))))
(deftransform min ((x y) (real real) *)
- (let ((x-type (continuation-type x))
- (y-type (continuation-type y))
+ (let ((x-type (lvar-type x))
+ (y-type (lvar-type y))
(signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
(unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
(d-float (specifier-type 'double-float))
(deftransform complement ((fun) * * :node node)
"open code"
(multiple-value-bind (min max)
- (fun-type-nargs (continuation-type fun))
+ (fun-type-nargs (lvar-type fun))
(cond
((and min (eql min max))
(let ((dums (make-gensym-list min)))
`#'(lambda ,dums (not (funcall fun ,@dums)))))
- ((let* ((cont (node-cont node))
- (dest (continuation-dest cont)))
- (and (combination-p dest)
- (eq (combination-fun dest) cont)))
+ ((awhen (node-lvar node)
+ (let ((dest (lvar-dest it)))
+ (and (combination-p dest)
+ (eq (combination-fun dest) it))))
'#'(lambda (&rest args)
(not (apply fun args))))
(t
(deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
"convert NTHCDR to CAxxR"
- (unless (constant-continuation-p n)
+ (unless (constant-lvar-p n)
(give-up-ir1-transform))
- (let ((n (continuation-value n)))
+ (let ((n (lvar-value n)))
(when (> n
(if (policy node (and (= speed 3) (= space 0)))
*extreme-nthcdr-open-code-limit*
;;; integer type with bounds determined Fun when applied to X and Y.
;;; Otherwise, we use Numeric-Contagion.
(defun derive-integer-type (x y fun)
- (declare (type continuation x y) (type function fun))
- (let ((x (continuation-type x))
- (y (continuation-type y)))
+ (declare (type lvar x y) (type function fun))
+ (let ((x (lvar-type x))
+ (y (lvar-type y)))
(if (and (numeric-type-p x) (numeric-type-p y)
(eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer)
&optional (convert-type t))
(declare (type function derive-fun)
(type (or null function) member-fun))
- (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
+ (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg))))
(when arg-list
(flet ((deriver (x)
(typecase x
(t
*universal-type*))))
(let ((same-arg (same-leaf-ref-p arg1 arg2))
- (a1 (prepare-arg-for-derive-type (continuation-type arg1)))
- (a2 (prepare-arg-for-derive-type (continuation-type arg2))))
+ (a1 (prepare-arg-for-derive-type (lvar-type arg1)))
+ (a2 (prepare-arg-for-derive-type (lvar-type arg2))))
(when (and a1 a2)
(let ((results nil))
(if same-arg
nil))))))))
(defoptimizer (/ derive-type) ((x y))
- (numeric-contagion (continuation-type x) (continuation-type y)))
+ (numeric-contagion (lvar-type x) (lvar-type y)))
) ; PROGN
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (abs derive-type) ((num))
- (let ((type (continuation-type num)))
+ (let ((type (lvar-type num)))
(if (and (numeric-type-p type)
(eq (numeric-type-class type) 'integer)
(eq (numeric-type-complexp type) :real))
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (truncate derive-type) ((number divisor))
- (let ((number-type (continuation-type number))
- (divisor-type (continuation-type divisor))
+ (let ((number-type (lvar-type number))
+ (divisor-type (lvar-type divisor))
(integer-type (specifier-type 'integer)))
(if (and (numeric-type-p number-type)
(csubtypep number-type integer-type)
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (random derive-type) ((bound &optional state))
- (let ((type (continuation-type bound)))
+ (let ((type (lvar-type bound)))
(when (numeric-type-p type)
(let ((class (numeric-type-class type))
(high (numeric-type-high type))
;;;; miscellaneous derive-type methods
(defoptimizer (integer-length derive-type) ((x))
- (let ((x-type (continuation-type x)))
+ (let ((x-type (lvar-type x)))
(when (and (numeric-type-p x-type)
(csubtypep x-type (specifier-type 'integer)))
;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
(specifier-type 'base-char))
(defoptimizer (values derive-type) ((&rest values))
- (make-values-type :required (mapcar #'continuation-type values)))
+ (make-values-type :required (mapcar #'lvar-type values)))
\f
;;;; byte operations
;;;;
`(%deposit-field ,newbyte ,size ,pos ,int))))
(defoptimizer (%ldb derive-type) ((size posn num))
- (let ((size (continuation-type size)))
+ (let ((size (lvar-type size)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer)))
(let ((size-high (numeric-type-high size)))
*universal-type*)))
(defoptimizer (%mask-field derive-type) ((size posn num))
- (let ((size (continuation-type size))
- (posn (continuation-type posn)))
+ (let ((size (lvar-type size))
+ (posn (lvar-type posn)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer))
(numeric-type-p posn)
*universal-type*)))
(defun %deposit-field-derive-type-aux (size posn int)
- (let ((size (continuation-type size))
- (posn (continuation-type posn))
- (int (continuation-type int)))
+ (let ((size (lvar-type size))
+ (posn (lvar-type posn))
+ (int (lvar-type int)))
(when (and (numeric-type-p size)
(numeric-type-p posn)
(numeric-type-p int))
;;; replaced with the version, cutting its result to WIDTH or more
;;; bits. If we have changed anything, we need to flush old derived
;;; types, because they have nothing in common with the new code.
-(defun cut-to-width (cont width)
- (declare (type continuation cont) (type (integer 0) width))
+(defun cut-to-width (lvar width)
+ (declare (type lvar lvar) (type (integer 0) width))
(labels ((reoptimize-node (node name)
(setf (node-derived-type node)
(fun-type-returns
(info :function :type name)))
- (setf (continuation-%derived-type (node-cont node)) nil)
+ (setf (lvar-%derived-type (node-lvar node)) nil)
(setf (node-reoptimize node) t)
(setf (block-reoptimize (node-block node)) t)
(setf (component-reoptimize (node-component node)) t))
(cut-node (node &aux did-something)
(when (and (combination-p node)
(fun-info-p (basic-combination-kind node)))
- (let* ((fun-ref (continuation-use (combination-fun node)))
+ (let* ((fun-ref (lvar-use (combination-fun node)))
(fun-name (leaf-source-name (ref-leaf fun-ref)))
(modular-fun (find-modular-version fun-name width))
(name (and (modular-fun-info-p modular-fun)
(find-free-fun name "in a strange place"))
(setf (combination-kind node) :full))
(dolist (arg (basic-combination-args node))
- (when (cut-continuation arg)
+ (when (cut-lvar arg)
(setq did-something t)))
(when did-something
(reoptimize-node node fun-name))
did-something))))
- (cut-continuation (cont &aux did-something)
- (do-uses (node cont)
+ (cut-lvar (lvar &aux did-something)
+ (do-uses (node lvar)
(when (cut-node node)
(setq did-something t)))
did-something))
- (cut-continuation cont)))
+ (cut-lvar lvar)))
(defoptimizer (logand optimizer) ((x y) node)
(let ((result-type (single-value-type (node-derived-type node))))
;;; If a constant appears as the first arg, swap the args.
(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
- (if (and (constant-continuation-p x)
- (not (constant-continuation-p y)))
- `(,(continuation-fun-name (basic-combination-fun node))
+ (if (and (constant-lvar-p x)
+ (not (constant-lvar-p y)))
+ `(,(lvar-fun-name (basic-combination-fun node))
y
- ,(continuation-value x))
+ ,(lvar-value x))
(give-up-ir1-transform)))
(dolist (x '(= char= + * logior logand logxor))
;;; Handle the case of a constant BOOLE-CODE.
(deftransform boole ((op x y) * *)
"convert to inline logical operations"
- (unless (constant-continuation-p op)
+ (unless (constant-lvar-p op)
(give-up-ir1-transform "BOOLE code is not a constant."))
- (let ((control (continuation-value op)))
+ (let ((control (lvar-value op)))
(case control
(#.boole-clr 0)
(#.boole-set -1)
;;; If arg is a constant power of two, turn * into a shift.
(deftransform * ((x y) (integer integer) *)
"convert x*2^k to shift"
- (unless (constant-continuation-p y)
+ (unless (constant-lvar-p y)
(give-up-ir1-transform))
- (let* ((y (continuation-value y))
+ (let* ((y (lvar-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len))
;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
;;; remainder.
(flet ((frob (y ceil-p)
- (unless (constant-continuation-p y)
+ (unless (constant-lvar-p y)
(give-up-ir1-transform))
- (let* ((y (continuation-value y))
+ (let* ((y (lvar-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len))
;;; Do the same for MOD.
(deftransform mod ((x y) (integer integer) *)
"convert remainder mod 2^k to LOGAND"
- (unless (constant-continuation-p y)
+ (unless (constant-lvar-p y)
(give-up-ir1-transform))
- (let* ((y (continuation-value y))
+ (let* ((y (lvar-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len))
;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
(deftransform truncate ((x y) (integer integer))
"convert division by 2^k to shift"
- (unless (constant-continuation-p y)
+ (unless (constant-lvar-p y)
(give-up-ir1-transform))
- (let* ((y (continuation-value y))
+ (let* ((y (lvar-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len))
;;; And the same for REM.
(deftransform rem ((x y) (integer integer) *)
"convert remainder mod 2^k to LOGAND"
- (unless (constant-continuation-p y)
+ (unless (constant-lvar-p y)
(give-up-ir1-transform))
- (let* ((y (continuation-value y))
+ (let* ((y (lvar-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len))
(deftransform logand ((x y) (* (constant-arg t)) *)
"fold identity operation"
- (let ((y (continuation-value y)))
+ (let ((y (lvar-value y)))
(unless (and (plusp y)
(= y (1- (ash 1 (integer-length y)))))
(give-up-ir1-transform))
- (unless (csubtypep (continuation-type x)
+ (unless (csubtypep (lvar-type x)
(specifier-type `(integer 0 ,y)))
(give-up-ir1-transform))
'x))
#+nil
(defun not-more-contagious (x y)
(declare (type continuation x y))
- (let ((x (continuation-type x))
- (y (continuation-type y)))
+ (let ((x (lvar-type x))
+ (y (lvar-type y)))
(values (type= (numeric-contagion x y)
(numeric-contagion y y)))))
;;; Patched version by Raymond Toy. dtc: Should be safer although it
;;; specific to particular transform functions so the use of this
;;; function may need a re-think.
(defun not-more-contagious (x y)
- (declare (type continuation x y))
+ (declare (type lvar x y))
(flet ((simple-numeric-type (num)
(and (numeric-type-p num)
;; Return non-NIL if NUM is integer, rational, or a float
(numeric-type-format num))
(t
nil)))))
- (let ((x (continuation-type x))
- (y (continuation-type y)))
+ (let ((x (lvar-type x))
+ (y (lvar-type y)))
(if (and (simple-numeric-type x)
(simple-numeric-type y))
(values (type= (numeric-contagion x y)
;;; float +0.0 then give up.
(deftransform + ((x y) (t (constant-arg t)) *)
"fold zero arg"
- (let ((val (continuation-value y)))
+ (let ((val (lvar-value y)))
(unless (and (zerop val)
(not (and (floatp val) (plusp (float-sign val))))
(not-more-contagious y x))
;;; float -0.0 then give up.
(deftransform - ((x y) (t (constant-arg t)) *)
"fold zero arg"
- (let ((val (continuation-value y)))
+ (let ((val (lvar-value y)))
(unless (and (zerop val)
(not (and (floatp val) (minusp (float-sign val))))
(not-more-contagious y x))
(macrolet ((def (name result minus-result)
`(deftransform ,name ((x y) (t (constant-arg real)) *)
"fold identity operations"
- (let ((val (continuation-value y)))
+ (let ((val (lvar-value y)))
(unless (and (= (abs val) 1)
(not-more-contagious y x))
(give-up-ir1-transform))
;;; N; convert (expt x 1/2) to sqrt.
(deftransform expt ((x y) (t (constant-arg real)) *)
"recode as multiplication or sqrt"
- (let ((val (continuation-value y)))
+ (let ((val (lvar-value y)))
;; If Y would cause the result to be promoted to the same type as
;; Y, we give up. If not, then the result will be the same type
;; as X, so we can replace the exponentiation with simple
(unless (not-more-contagious y x)
(give-up-ir1-transform))
(cond ((zerop val)
- (let ((x-type (continuation-type x)))
+ (let ((x-type (lvar-type x)))
(cond ((csubtypep x-type (specifier-type '(or rational
(complex rational))))
'1)
;;; reference to the same leaf, and the value of the leaf cannot
;;; change.
(defun same-leaf-ref-p (x y)
- (declare (type continuation x y))
- (let ((x-use (principal-continuation-use x))
- (y-use (principal-continuation-use y)))
+ (declare (type lvar x y))
+ (let ((x-use (principal-lvar-use x))
+ (y-use (principal-lvar-use y)))
(and (ref-p x-use)
(ref-p y-use)
(eq (ref-leaf x-use) (ref-leaf y-use))
:defun-only t)
(cond ((same-leaf-ref-p x y)
t)
- ((not (types-equal-or-intersect (continuation-type x)
- (continuation-type y)))
+ ((not (types-equal-or-intersect (lvar-type x)
+ (lvar-type y)))
nil)
(t
(give-up-ir1-transform))))
;;; handle that case, otherwise give an efficiency note.
(deftransform eql ((x y) * *)
"convert to simpler equality predicate"
- (let ((x-type (continuation-type x))
- (y-type (continuation-type y))
+ (let ((x-type (lvar-type x))
+ (y-type (lvar-type y))
(char-type (specifier-type 'character))
(number-type (specifier-type 'number)))
(cond ((same-leaf-ref-p x y)
((or (not (types-equal-or-intersect x-type number-type))
(not (types-equal-or-intersect y-type number-type)))
'(eq x y))
- ((and (not (constant-continuation-p y))
- (or (constant-continuation-p x)
+ ((and (not (constant-lvar-p y))
+ (or (constant-lvar-p x)
(and (csubtypep x-type y-type)
(not (csubtypep y-type x-type)))))
'(eql y x))
;;; and the same for both.
(deftransform = ((x y) * *)
"open code"
- (let ((x-type (continuation-type x))
- (y-type (continuation-type y)))
+ (let ((x-type (lvar-type x))
+ (y-type (lvar-type y)))
(if (and (csubtypep x-type (specifier-type 'number))
(csubtypep y-type (specifier-type 'number)))
(cond ((or (and (csubtypep x-type (specifier-type 'float))
;;; If CONT's type is a numeric type, then return the type, otherwise
;;; GIVE-UP-IR1-TRANSFORM.
-(defun numeric-type-or-lose (cont)
- (declare (type continuation cont))
- (let ((res (continuation-type cont)))
+(defun numeric-type-or-lose (lvar)
+ (declare (type lvar lvar))
+ (let ((res (lvar-type lvar)))
(unless (numeric-type-p res) (give-up-ir1-transform))
res))
t)
((and y-hi x-lo (>= x-lo y-hi))
nil)
- ((and (constant-continuation-p first)
- (not (constant-continuation-p second)))
+ ((and (constant-lvar-p first)
+ (not (constant-lvar-p second)))
`(,inverse y x))
(t
(give-up-ir1-transform))))))
t)
((interval->= xi yi)
nil)
- ((and (constant-continuation-p first)
- (not (constant-continuation-p second)))
+ ((and (constant-lvar-p first)
+ (not (constant-lvar-p second)))
`(,inverse y x))
(t
(give-up-ir1-transform))))))
;; might eventually have to to support 2^21 characters, then here
;; we could do some compile-time computation as in IR1-TRANSFORM-<
;; above. -- CSR, 2003-07-01
- ((and (constant-continuation-p first)
- (not (constant-continuation-p second)))
+ ((and (constant-lvar-p first)
+ (not (constant-lvar-p second)))
`(,inverse y x))
(t (give-up-ir1-transform))))
;;; ensure (with THE) that the argument in one-argument calls is.
(defun source-transform-transitive (fun args identity
&optional one-arg-result-type)
- (declare (symbol fun leaf-fun) (list args))
+ (declare (symbol fun) (list args))
(case (length args)
(0 identity)
(1 (if one-arg-result-type
nargs fun string max)))))))
(defoptimizer (format optimizer) ((dest control &rest args))
- (when (constant-continuation-p control)
- (let ((x (continuation-value control)))
+ (when (constant-lvar-p control)
+ (let ((x (lvar-value control)))
(when (stringp x)
(check-format-args x args 'format)))))
(deftransform format ((dest control &rest args) (t simple-string &rest t) *
:policy (> speed space))
- (unless (constant-continuation-p control)
+ (unless (constant-lvar-p control)
(give-up-ir1-transform "The control string is not a constant."))
(let ((arg-names (make-gensym-list (length args))))
`(lambda (dest control ,@arg-names)
(declare (ignore control))
- (format dest (formatter ,(continuation-value control)) ,@arg-names))))
+ (format dest (formatter ,(lvar-value control)) ,@arg-names))))
(deftransform format ((stream control &rest args) (stream function &rest t) *
:policy (> speed space))
(macrolet
((def (name)
`(defoptimizer (,name optimizer) ((control &rest args))
- (when (constant-continuation-p control)
- (let ((x (continuation-value control)))
+ (when (constant-lvar-p control)
+ (let ((x (lvar-value control)))
(when (stringp x)
(check-format-args x args ',name)))))))
(def error)
(def bug)))
(defoptimizer (cerror optimizer) ((report control &rest args))
- (when (and (constant-continuation-p control)
- (constant-continuation-p report))
- (let ((x (continuation-value control))
- (y (continuation-value report)))
+ (when (and (constant-lvar-p control)
+ (constant-lvar-p report))
+ (let ((x (lvar-value control))
+ (y (lvar-value report)))
(when (and (stringp x) (stringp y))
(multiple-value-bind (min1 max1)
(handler-case
(defoptimizer (coerce derive-type) ((value type))
(cond
- ((constant-continuation-p type)
+ ((constant-lvar-p type)
;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
;; but dealing with the niggle that complex canonicalization gets
;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
;; type COMPLEX.
- (let* ((specifier (continuation-value type))
+ (let* ((specifier (lvar-value type))
(result-typeoid (careful-specifier-type specifier)))
(cond
((null result-typeoid) nil)
;; case, we will return a complex or an object of the
;; provided type if it's rational:
(type-union result-typeoid
- (type-intersection (continuation-type value)
+ (type-intersection (lvar-type value)
(specifier-type 'rational))))))
(t result-typeoid))))
(t
;; the basis that it's unlikely that other uses are both
;; time-critical and get to this branch of the COND (non-constant
;; second argument to COERCE). -- CSR, 2002-12-16
- (let ((value-type (continuation-type value))
- (type-type (continuation-type type)))
+ (let ((value-type (lvar-type value))
+ (type-type (lvar-type type)))
(labels
((good-cons-type-p (cons-type)
;; Make sure the cons-type we're looking at is something
*universal-type*)))))))
(defoptimizer (compile derive-type) ((nameoid function))
- (when (csubtypep (continuation-type nameoid)
+ (when (csubtypep (lvar-type nameoid)
(specifier-type 'null))
(values-specifier-type '(values function boolean boolean))))
;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
;;; optimizer, above).
(defoptimizer (array-element-type derive-type) ((array))
- (let ((array-type (continuation-type array)))
+ (let ((array-type (lvar-type array)))
(labels ((consify (list)
(if (endp list)
'(eql nil)
;;; and the function doesn't do anything at all.)
#!+sb-show
(progn
- (defknown /report-continuation (t t) null)
- (deftransform /report-continuation ((x message) (t t))
- (format t "~%/in /REPORT-CONTINUATION~%")
- (format t "/(CONTINUATION-TYPE X)=~S~%" (continuation-type x))
- (when (constant-continuation-p x)
- (format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x)))
- (format t "/MESSAGE=~S~%" (continuation-value message))
+ (defknown /report-lvar (t t) null)
+ (deftransform /report-lvar ((x message) (t t))
+ (format t "~%/in /REPORT-LVAR~%")
+ (format t "/(LVAR-TYPE X)=~S~%" (lvar-type x))
+ (when (constant-lvar-p x)
+ (format t "/(LVAR-VALUE X)=~S~%" (lvar-value x)))
+ (format t "/MESSAGE=~S~%" (lvar-value message))
(give-up-ir1-transform "not a real transform"))
- (defun /report-continuation (x message)
+ (defun /report-lvar (x message)
(declare (ignore x message))))
;;; Scan through BLOCK looking for uses of :UNKNOWN continuations that
;;; have their DEST outside of the block. We do some checking to
;;; verify the invariant that all pushes come after the last pop.
-(defun find-pushed-continuations (block)
+(defun find-pushed-lvars (block)
(let* ((2block (block-info block))
(popped (ir2-block-popped 2block))
(last-pop (if popped
- (continuation-dest (car (last popped)))
+ (lvar-dest (car (last popped)))
nil)))
(collect ((pushed))
(let ((saw-last nil))
- (do-nodes (node cont block)
+ (do-nodes (node lvar block)
(when (eq node last-pop)
(setq saw-last t))
- (let ((dest (continuation-dest cont))
- (2cont (continuation-info cont)))
- (when (and dest
- (not (eq (node-block dest) block))
- 2cont
- (eq (ir2-continuation-kind 2cont) :unknown))
- (aver (or saw-last (not last-pop)))
- (pushed cont)))))
+ (when lvar
+ (let ((dest (lvar-dest lvar))
+ (2lvar (lvar-info lvar)))
+ (when (and (not (eq (node-block dest) block))
+ 2lvar
+ (eq (ir2-lvar-kind 2lvar) :unknown))
+ (aver (or saw-last (not last-pop)))
+ (pushed lvar))))))
(setf (ir2-block-pushed 2block) (pushed))))
(values))
(let* ((2block (block-info block))
(stack (ir2-block-end-stack 2block))
(last (block-last block))
- (tailp-cont (if (node-tail-p last) (node-cont last))))
+ (tailp-lvar (if (node-tail-p last) (node-lvar last))))
(do ((pushes (ir2-block-pushed 2block) (rest pushes))
(popping nil))
((null pushes))
(let ((push (first pushes)))
(cond ((member push stack)
(aver (not popping)))
- ((eq push tailp-cont)
+ ((eq push tailp-lvar)
(aver (null (rest pushes))))
(t
(push push (ir2-block-end-stack 2block))
(aver (tailp block2-stack block1-stack))
(let* ((block (insert-cleanup-code block1 block2
- (continuation-next (block-start block2))
+ (block-start-node block2)
`(%pop-values ',last-popped)))
(2block (make-ir2-block block)))
(setf (block-info block) 2block)
(generators (find-values-generators receivers)))
(dolist (block generators)
- (find-pushed-continuations block))
+ (find-pushed-lvars block))
(dolist (block receivers)
(unless (ir2-block-start-stack (block-info block))
;;; spurious attempts at transformation (and possible repeated
;;; warnings.)
(deftransform typep ((object type))
- (unless (constant-continuation-p type)
+ (unless (constant-lvar-p type)
(give-up-ir1-transform "can't open-code test of non-constant type"))
- `(typep object ',(continuation-value type)))
+ `(typep object ',(lvar-value type)))
-;;; If the continuation OBJECT definitely is or isn't of the specified
+;;; If the lvar OBJECT definitely is or isn't of the specified
;;; type, then return T or NIL as appropriate. Otherwise quietly
;;; GIVE-UP-IR1-TRANSFORM.
(defun ir1-transform-type-predicate (object type)
- (declare (type continuation object) (type ctype type))
- (let ((otype (continuation-type object)))
+ (declare (type lvar object) (type ctype type))
+ (let ((otype (lvar-type object)))
(cond ((not (types-equal-or-intersect otype type))
nil)
((csubtypep otype type)
;;; Flush %TYPEP tests whose result is known at compile time.
(deftransform %typep ((object type))
- (unless (constant-continuation-p type)
+ (unless (constant-lvar-p type)
(give-up-ir1-transform))
(ir1-transform-type-predicate
object
- (ir1-transform-specifier-type (continuation-value type))))
+ (ir1-transform-specifier-type (lvar-value type))))
;;; This is the IR1 transform for simple type predicates. It checks
;;; whether the single argument is known to (not) be of the
(deftransform fold-type-predicate ((object) * * :node node :defun-only t)
(let ((ctype (gethash (leaf-source-name
(ref-leaf
- (continuation-use
+ (lvar-uses
(basic-combination-fun node))))
*backend-predicate-types*)))
(aver ctype)
;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
;;; at load time.
(deftransform find-classoid ((name) ((constant-arg symbol)) *)
- (let* ((name (continuation-value name))
+ (let* ((name (lvar-value name))
(cell (find-classoid-cell name)))
`(or (classoid-cell-classoid ',cell)
(error "class not yet defined: ~S" name))))
;;; and signal an error if so. Otherwise, look up the indirect
;;; class-cell and call CLASS-CELL-TYPEP at runtime.
(deftransform %instance-typep ((object spec) (* *) * :node node)
- (aver (constant-continuation-p spec))
- (let* ((spec (continuation-value spec))
+ (aver (constant-lvar-p spec))
+ (let* ((spec (lvar-value spec))
(class (specifier-type spec))
(name (classoid-name class))
- (otype (continuation-type object))
+ (otype (lvar-type object))
(layout (let ((res (info :type :compiler-layout name)))
(if (and res (not (layout-invalid res)))
res
;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
;; since that would overlook other kinds of constants. But it turns
;; out that the DEFTRANSFORM for TYPEP detects any constant
- ;; continuation, transforms it into a quoted form, and gives this
+ ;; lvar, transforms it into a quoted form, and gives this
;; source transform another chance, so it all works out OK, in a
;; weird roundabout way. -- WHN 2001-03-18
(if (and (consp spec) (eq (car spec) 'quote))
;;;; coercion
(deftransform coerce ((x type) (* *) * :node node)
- (unless (constant-continuation-p type)
+ (unless (constant-lvar-p type)
(give-up-ir1-transform))
- (let ((tspec (ir1-transform-specifier-type (continuation-value type))))
- (if (csubtypep (continuation-type x) tspec)
+ (let ((tspec (ir1-transform-specifier-type (lvar-value type))))
+ (if (csubtypep (lvar-type x) tspec)
'x
;; Note: The THE here makes sure that specifiers like
;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR.
- `(the ,(continuation-value type)
+ `(the ,(lvar-value type)
,(cond
((csubtypep tspec (specifier-type 'double-float))
'(%double-float x))
;;; COMPONENT-INFO
;;; Holds the IR2-COMPONENT structure.
;;;
-;;; CONTINUATION-INFO
-;;; Holds the IR2-CONTINUATION structure. Continuations whose
-;;; values aren't used won't have any.
+;;; LVAR-INFO
+;;; Holds the IR2-LVAR structure. LVARs whose values aren't used
+;;; won't have any. XXX
;;;
;;; CLEANUP-INFO
;;; If non-null, then a TN in which the affected dynamic
;; the IR2-BLOCK's number, which differs from BLOCK's BLOCK-NUMBER
;; if any blocks are split. This is assigned by lifetime analysis.
(number nil :type (or index null))
- ;; information about unknown-values continuations that is used by
- ;; stack analysis to do stack simulation. An UNKNOWN-VALUES
- ;; continuation is PUSHED if its DEST is in another block.
- ;; Similarly, a continuation is POPPED if its DEST is in this block
- ;; but has its uses elsewhere. The continuations are in the order
- ;; that are pushed/popped in the block. Note that the args to a
- ;; single MV-COMBINATION appear reversed in POPPED, since we must
- ;; effectively pop the last argument first. All pops must come
- ;; before all pushes (although internal MV uses may be interleaved.)
- ;; POPPED is computed by LTN, and PUSHED is computed by stack
- ;; analysis.
+ ;; information about unknown-values LVARs that is used by stack
+ ;; analysis to do stack simulation. An UNKNOWN-VALUES LVAR is PUSHED
+ ;; if its DEST is in another block. Similarly, a LVAR is POPPED if
+ ;; its DEST is in this block but has its uses elsewhere. The LVARs
+ ;; are in the order that are pushed/popped in the block. Note that
+ ;; the args to a single MV-COMBINATION appear reversed in POPPED,
+ ;; since we must effectively pop the last argument first. All pops
+ ;; must come before all pushes (although internal MV uses may be
+ ;; interleaved.) POPPED is computed by LTN, and PUSHED is computed
+ ;; by stack analysis.
(pushed () :type list)
(popped () :type list)
;; the result of stack analysis: lists of all the unknown-values
- ;; continuations on the stack at the block start and end, topmost
- ;; continuation first.
+ ;; LVARs on the stack at the block start and end, topmost LVAR
+ ;; first.
(start-stack () :type list)
(end-stack () :type list)
;; the first and last VOP in this block. If there are none, both
(local-tn-count :test (not (zerop local-tn-count)))
(%label :test %label))
-;;; An IR2-CONTINUATION structure is used to annotate continuations
-;;; that are used as a function result continuation or that receive MVs.
-(defstruct (ir2-continuation
- (:constructor make-ir2-continuation (primitive-type))
+;;; An IR2-LVAR structure is used to annotate LVARs that are used as a
+;;; function result LVARs or that receive MVs.
+(defstruct (ir2-lvar
+ (:constructor make-ir2-lvar (primitive-type))
(:copier nil))
- ;; If this is :DELAYED, then this is a single value continuation for
- ;; which the evaluation of the use is to be postponed until the
- ;; evaluation of destination. This can be done for ref nodes or
- ;; predicates whose destination is an IF.
+ ;; If this is :DELAYED, then this is a single value LVAR for which
+ ;; the evaluation of the use is to be postponed until the evaluation
+ ;; of destination. This can be done for ref nodes or predicates
+ ;; whose destination is an IF.
;;
- ;; If this is :FIXED, then this continuation has a fixed number of
- ;; values, with the TNs in LOCS.
+ ;; If this is :FIXED, then this LVAR has a fixed number of values,
+ ;; with the TNs in LOCS.
;;
- ;; If this is :UNKNOWN, then this is an unknown-values continuation,
- ;; using the passing locations in LOCS.
+ ;; If this is :UNKNOWN, then this is an unknown-values LVAR, using
+ ;; the passing locations in LOCS.
;;
- ;; If this is :UNUSED, then this continuation should never actually
- ;; be used as the destination of a value: it is only used
- ;; tail-recursively.
+ ;; If this is :UNUSED, then this LVAR should never actually be used
+ ;; as the destination of a value: it is only used tail-recursively.
(kind :fixed :type (member :delayed :fixed :unknown :unused))
- ;; The primitive-type of the first value of this continuation. This
- ;; is primarily for internal use during LTN, but it also records the
+ ;; The primitive-type of the first value of this LVAR. This is
+ ;; primarily for internal use during LTN, but it also records the
;; type restriction on delayed references. In multiple-value
;; contexts, this is null to indicate that it is meaningless. This
- ;; is always (primitive-type (continuation-type cont)), which may be
- ;; more restrictive than the tn-primitive-type of the value TN. This
- ;; is becase the value TN must hold any possible type that could be
- ;; computed (before type checking.)
+ ;; is always (primitive-type (lvar-type cont)), which may be more
+ ;; restrictive than the tn-primitive-type of the value TN. This is
+ ;; becase the value TN must hold any possible type that could be
+ ;; computed (before type checking.) XXX
(primitive-type nil :type (or primitive-type null))
- ;; Locations used to hold the values of the continuation. If the
- ;; number of values if fixed, then there is one TN per value. If the
- ;; number of values is unknown, then this is a two-list of TNs
- ;; holding the start of the values glob and the number of values.
- ;; Note that since type checking is the responsibility of the values
- ;; receiver, these TNs primitive type is only based on the proven
- ;; type information.
+ ;; Locations used to hold the values of the LVAR. If the number of
+ ;; values if fixed, then there is one TN per value. If the number of
+ ;; values is unknown, then this is a two-list of TNs holding the
+ ;; start of the values glob and the number of values. Note that
+ ;; since type checking is the responsibility of the values receiver,
+ ;; these TNs primitive type is only based on the proven type
+ ;; information.
(locs nil :type list))
-(defprinter (ir2-continuation)
+(defprinter (ir2-lvar)
kind
primitive-type
locs)
;;; An ENTRY-INFO condenses all the information that the dumper needs
;;; to create each XEP's function entry data structure. ENTRY-INFO
-;;; structures are somtimes created before they are initialized, since
-;;; IR2 conversion may need to compile a forward reference. In this
-;;; case the slots aren't actually initialized until entry analysis runs.
+;;; structures are sometimes created before they are initialized,
+;;; since IR2 conversion may need to compile a forward reference. In
+;;; this case the slots aren't actually initialized until entry
+;;; analysis runs.
(defstruct (entry-info (:copier nil))
;; Does this function have a non-null closure environment?
(closure-p nil :type boolean)
(foldable flushable))
(defoptimizer (%lea derive-type) ((base index scale disp))
- (when (and (constant-continuation-p scale)
- (constant-continuation-p disp))
- (let ((scale (continuation-value scale))
- (disp (continuation-value disp))
- (base-type (continuation-type base))
- (index-type (continuation-type index)))
+ (when (and (constant-lvar-p scale)
+ (constant-lvar-p disp))
+ (let ((scale (lvar-value scale))
+ (disp (lvar-value disp))
+ (base-type (lvar-type base))
+ (index-type (lvar-type index)))
(when (and (numeric-type-p base-type)
(numeric-type-p index-type))
(let ((base-lo (numeric-type-low base-type))
((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
(unsigned-byte 32))
"recode as leas, shifts and adds"
- (let ((y (continuation-value y)))
+ (let ((y (lvar-value y)))
(cond
((= y (ash 1 (integer-length y)))
;; there's a generic transform for y = 2^k
(deftransform %alien-funcall ((function type &rest args) * * :node node)
- (aver (sb!c::constant-continuation-p type))
- (let* ((type (sb!c::continuation-value type))
+ (aver (sb!c::constant-lvar-p type))
+ (let* ((type (sb!c::lvar-value type))
(env (sb!c::node-lexenv node))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(movable foldable flushable explicit-check))
(deftransform sb-pcl::pcl-instance-p ((object))
- (let* ((otype (continuation-type object))
+ (let* ((otype (lvar-type object))
(std-obj (specifier-type 'sb-pcl::std-object)))
(cond
;; Flush tests whose result is known at compile time.
(optimize speed))
(* x (* y x)))
+(defun #:foo (b)
+ (declare (type (integer -290488443 2) b)
+ (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((v3 (min -1720 b))) (max v3 (logcount (if (= v3 b) b b)))))
+
;;; bug 282
;;;
;;; Verify type checking policy in full calls: the callee is supposed
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.3.61"
+"0.8.3.62"
projects / sbcl.git / commitdiff