(flushable movable))
(defknown deport (alien alien-type) t
(flushable movable))
-(defknown extract-alien-value (system-area-pointer index alien-type) t
+(defknown deport-alloc (alien alien-type) t
+ (flushable movable))
+(defknown %alien-value (system-area-pointer unsigned-byte alien-type) t
(flushable))
-(defknown deposit-alien-value (system-area-pointer index alien-type t) t
+(defknown (setf %alien-value) (t system-area-pointer unsigned-byte alien-type) t
())
(defknown alien-funcall (alien-value &rest *) *
(any recursive))
-(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
\f
;;;; cosmetic transforms
(deftransform slot ((object slot)
- ((alien (* t)) symbol))
+ ((alien (* t)) symbol))
'(slot (deref object) slot))
(deftransform %set-slot ((object slot value)
- ((alien (* t)) symbol t))
+ ((alien (* t)) symbol t))
'(%set-slot (deref object) slot value))
(deftransform %slot-addr ((object slot)
- ((alien (* t)) symbol))
+ ((alien (* t)) symbol))
'(%slot-addr (deref object) slot))
\f
;;;; 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))
- (field (find slot-name (alien-record-type-fields alien-type)
- :key #'alien-record-field-name)))
- (unless field
- (abort-ir1-transform "~S doesn't have a slot named ~S"
- alien
- slot-name))
- (values (alien-record-field-offset field)
- (alien-record-field-type field))))))
+ (give-up-ir1-transform))
+ (let* ((slot-name (lvar-value slot))
+ (field (find slot-name (alien-record-type-fields alien-type)
+ :key #'alien-record-field-name)))
+ (unless field
+ (abort-ir1-transform "~S doesn't have a slot named ~S"
+ alien
+ slot-name))
+ (values (alien-record-field-offset field)
+ (alien-record-field-type field))))))
#+nil ;; Shouldn't be necessary.
(defoptimizer (slot derive-type) ((alien slot))
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (slot-offset slot-type)
- (find-slot-offset-and-type alien slot)
- (declare (ignore slot-offset))
- (return (make-alien-type-type slot-type))))
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (return (make-alien-type-type slot-type))))
*wild-type*))
(deftransform slot ((alien slot) * * :important t)
(multiple-value-bind (slot-offset slot-type)
(find-slot-offset-and-type alien slot)
- `(extract-alien-value (alien-sap alien)
- ,slot-offset
- ',slot-type)))
+ `(%alien-value (alien-sap alien)
+ ,slot-offset
+ ',slot-type)))
#+nil ;; ### But what about coercions?
(defoptimizer (%set-slot derive-type) ((alien slot value))
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (slot-offset slot-type)
- (find-slot-offset-and-type alien slot)
- (declare (ignore slot-offset))
- (let ((type (make-alien-type-type slot-type)))
- (assert-continuation-type value type)
- (return type))))
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (let ((type (make-alien-type-type slot-type)))
+ (assert-lvar-type value type)
+ (return type))))
*wild-type*))
(deftransform %set-slot ((alien slot value) * * :important t)
(multiple-value-bind (slot-offset slot-type)
(find-slot-offset-and-type alien slot)
- `(deposit-alien-value (alien-sap alien)
- ,slot-offset
- ',slot-type
- value)))
+ `(setf (%alien-value (alien-sap alien)
+ ,slot-offset
+ ',slot-type)
+ value)))
(defoptimizer (%slot-addr derive-type) ((alien slot))
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (slot-offset slot-type)
- (find-slot-offset-and-type alien slot)
- (declare (ignore slot-offset))
- (return (make-alien-type-type
- (make-alien-pointer-type :to slot-type)))))
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (return (make-alien-type-type
+ (make-alien-pointer-type :to slot-type)))))
*wild-type*))
(deftransform %slot-addr ((alien slot) * * :important t)
(find-slot-offset-and-type alien slot)
(/noshow "in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
`(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb!vm:n-byte-bits))
- ',(make-alien-pointer-type :to slot-type))))
+ ',(make-alien-pointer-type :to slot-type))))
\f
;;;; 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)))
(if (alien-type-p alien-type)
- alien-type
- (give-up-ir1-transform)))))
+ alien-type
+ (give-up-ir1-transform)))))
(defun find-deref-element-type (alien)
(let ((alien-type (find-deref-alien-type alien)))
(typecase alien-type
(alien-pointer-type
(when (cdr indices)
- (abort-ir1-transform "too many indices for pointer deref: ~D"
- (length indices)))
+ (abort-ir1-transform "too many indices for pointer deref: ~W"
+ (length indices)))
(let ((element-type (alien-pointer-type-to alien-type)))
- (if indices
- (let ((bits (alien-type-bits element-type))
- (alignment (alien-type-alignment element-type)))
- (unless bits
- (abort-ir1-transform "unknown element size"))
- (unless alignment
- (abort-ir1-transform "unknown element alignment"))
- (values '(offset)
- `(* offset
- ,(align-offset bits alignment))
- element-type))
- (values nil 0 element-type))))
+ (unless element-type
+ (give-up-ir1-transform "unable to open code deref of wild pointer type"))
+ (if indices
+ (let ((bits (alien-type-bits element-type))
+ (alignment (alien-type-alignment element-type)))
+ (unless bits
+ (abort-ir1-transform "unknown element size"))
+ (unless alignment
+ (abort-ir1-transform "unknown element alignment"))
+ (values '(offset)
+ `(* offset
+ ,(align-offset bits alignment))
+ element-type))
+ (values nil 0 element-type))))
(alien-array-type
(let* ((element-type (alien-array-type-element-type alien-type))
- (bits (alien-type-bits element-type))
- (alignment (alien-type-alignment element-type))
- (dims (alien-array-type-dimensions alien-type)))
- (unless (= (length indices) (length dims))
- (give-up-ir1-transform "incorrect number of indices"))
- (unless bits
- (give-up-ir1-transform "Element size is unknown."))
- (unless alignment
- (give-up-ir1-transform "Element alignment is unknown."))
- (if (null dims)
- (values nil 0 element-type)
- (let* ((arg (gensym))
- (args (list arg))
- (offsetexpr arg))
- (dolist (dim (cdr dims))
- (let ((arg (gensym)))
- (push arg args)
- (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
- (values (reverse args)
- `(* ,offsetexpr
- ,(align-offset bits alignment))
- element-type)))))
+ (bits (alien-type-bits element-type))
+ (alignment (alien-type-alignment element-type))
+ (dims (alien-array-type-dimensions alien-type)))
+ (unless (= (length indices) (length dims))
+ (give-up-ir1-transform "incorrect number of indices"))
+ (unless bits
+ (give-up-ir1-transform "Element size is unknown."))
+ (unless alignment
+ (give-up-ir1-transform "Element alignment is unknown."))
+ (if (null dims)
+ (values nil 0 element-type)
+ (let* ((arg (gensym))
+ (args (list arg))
+ (offsetexpr arg))
+ (dolist (dim (cdr dims))
+ (let ((arg (gensym)))
+ (push arg args)
+ (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
+ (values (reverse args)
+ `(* ,offsetexpr
+ ,(align-offset bits alignment))
+ element-type)))))
(t
(abort-ir1-transform "~S not either a pointer or array type."
- alien-type)))))
+ alien-type)))))
#+nil ;; Shouldn't be necessary.
(defoptimizer (deref derive-type) ((alien &rest noise))
(multiple-value-bind (indices-args offset-expr element-type)
(compute-deref-guts alien indices)
`(lambda (alien ,@indices-args)
- (extract-alien-value (alien-sap alien)
- ,offset-expr
- ',element-type))))
+ (%alien-value (alien-sap alien)
+ ,offset-expr
+ ',element-type))))
#+nil ;; ### Again, the value might be coerced.
(defoptimizer (%set-deref derive-type) ((alien value &rest noise))
(block nil
(catch 'give-up-ir1-transform
(let ((type (make-alien-type-type
- (make-alien-pointer-type
- :to (find-deref-element-type alien)))))
- (assert-continuation-type value type)
- (return type)))
+ (make-alien-pointer-type
+ :to (find-deref-element-type alien)))))
+ (assert-lvar-type value type)
+ (return type)))
*wild-type*))
(deftransform %set-deref ((alien value &rest indices) * * :important t)
(multiple-value-bind (indices-args offset-expr element-type)
(compute-deref-guts alien indices)
`(lambda (alien value ,@indices-args)
- (deposit-alien-value (alien-sap alien)
- ,offset-expr
- ',element-type
- value))))
+ (setf (%alien-value (alien-sap alien)
+ ,offset-expr
+ ',element-type)
+ value))))
(defoptimizer (%deref-addr derive-type) ((alien &rest noise))
(declare (ignore noise))
(block nil
(catch 'give-up-ir1-transform
(return (make-alien-type-type
- (make-alien-pointer-type
- :to (find-deref-element-type alien)))))
+ (make-alien-pointer-type
+ :to (find-deref-element-type alien)))))
*wild-type*))
(deftransform %deref-addr ((alien &rest indices) * * :important t)
(/noshow "in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
`(lambda (alien ,@indices-args)
(%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb!vm:n-byte-bits))
- ',(make-alien-pointer-type :to element-type)))))
+ ',(make-alien-pointer-type :to element-type)))))
\f
;;;; 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))))
+ (heap-alien-info-type info))))
#+nil ; shouldn't be necessary
(defoptimizer (%heap-alien derive-type) ((info))
(block nil
(catch 'give-up
(multiple-value-bind (sap type) (heap-alien-sap-and-type info)
- (declare (ignore sap))
- (return (make-alien-type-type type))))
+ (declare (ignore sap))
+ (return (make-alien-type-type type))))
*wild-type*))
-(deftransform %heap-alien ((info) * * :important t)
+(deftransform %heap-alien ((info) ((constant-arg heap-alien-info)) * :important t)
(multiple-value-bind (sap type) (heap-alien-sap-and-type info)
- `(extract-alien-value ,sap 0 ',type)))
+ `(%alien-value ,sap 0 ',type)))
#+nil ;; ### Again, deposit value might change the type.
(defoptimizer (%set-heap-alien derive-type) ((info value))
(block nil
(catch 'give-up-ir1-transform
(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)
- (return type))))
+ (declare (ignore sap))
+ (let ((type (make-alien-type-type type)))
+ (assert-lvar-type value type)
+ (return type))))
*wild-type*))
(deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t)
(multiple-value-bind (sap type) (heap-alien-sap-and-type info)
- `(deposit-alien-value ,sap 0 ',type value)))
+ `(setf (%alien-value ,sap 0 ',type) value)))
(defoptimizer (%heap-alien-addr derive-type) ((info))
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (sap type) (heap-alien-sap-and-type info)
- (declare (ignore sap))
- (return (make-alien-type-type (make-alien-pointer-type :to type)))))
+ (declare (ignore sap))
+ (return (make-alien-type-type (make-alien-pointer-type :to type)))))
*wild-type*))
(deftransform %heap-alien-addr ((info) * * :important t)
(multiple-value-bind (sap type) (heap-alien-sap-and-type info)
(/noshow "in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
- `(%sap-alien ,sap ',type)))
+ `(%sap-alien ,sap ',(make-alien-pointer-type :to type))))
+
\f
;;;; support for local (stack or register) aliens
+(defun alien-info-constant-or-abort (info)
+ (unless (constant-lvar-p info)
+ (abort-ir1-transform "Local alien info isn't constant?")))
+
(deftransform make-local-alien ((info) * * :important t)
- (unless (constant-continuation-p info)
- (abort-ir1-transform "Local alien info isn't constant?"))
- (let* ((info (continuation-value info))
- (alien-type (local-alien-info-type info))
- (bits (alien-type-bits alien-type)))
+ (alien-info-constant-or-abort info)
+ (let* ((info (lvar-value info))
+ (alien-type (local-alien-info-type info))
+ (bits (alien-type-bits alien-type)))
(unless bits
(abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type)))
(/noshow "in DEFTRANSFORM MAKE-LOCAL-ALIEN" info)
(/noshow (local-alien-info-force-to-memory-p info))
(/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
(if (local-alien-info-force-to-memory-p info)
- #!+x86 `(truly-the system-area-pointer
- (%primitive alloc-alien-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits)))
- #!-x86 `(truly-the system-area-pointer
- (%primitive alloc-number-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits)))
- (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
- (alien-rep-type (specifier-type alien-rep-type-spec)))
- (cond ((csubtypep (specifier-type 'system-area-pointer)
- alien-rep-type)
- '(int-sap 0))
- ((ctypep 0 alien-rep-type) 0)
- ((ctypep 0.0f0 alien-rep-type) 0.0f0)
- ((ctypep 0.0d0 alien-rep-type) 0.0d0)
- (t
- (compiler-error
- "Aliens of type ~S cannot be represented immediately."
- (unparse-alien-type alien-type))))))))
+ #!+(or x86 x86-64)
+ `(%primitive alloc-alien-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits))
+ #!-(or x86 x86-64)
+ `(%primitive alloc-number-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits))
+ (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
+ (alien-rep-type (specifier-type alien-rep-type-spec)))
+ (cond ((csubtypep (specifier-type 'system-area-pointer)
+ alien-rep-type)
+ '(int-sap 0))
+ ((ctypep 0 alien-rep-type) 0)
+ ((ctypep 0.0f0 alien-rep-type) 0.0f0)
+ ((ctypep 0.0d0 alien-rep-type) 0.0d0)
+ (t
+ (compiler-error
+ "Aliens of type ~S cannot be represented immediately."
+ (unparse-alien-type alien-type))))))))
(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)
- (abort-ir1-transform "Local alien info isn't constant?"))
- (let ((info (continuation-value info)))
+ (alien-info-constant-or-abort 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)))
- (/noshow var-node (ref-p var-node))
- (when (ref-p var-node)
- (propagate-to-refs (ref-leaf var-node)
- (specifier-type
- (compute-alien-rep-type
- (local-alien-info-type info))))))))
+ (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)
+ (specifier-type
+ (compute-alien-rep-type
+ (local-alien-info-type info))))))))
nil)
(deftransform local-alien ((info var) * * :important t)
- (unless (constant-continuation-p info)
- (abort-ir1-transform "Local alien info isn't constant?"))
- (let* ((info (continuation-value info))
- (alien-type (local-alien-info-type info)))
+ (alien-info-constant-or-abort 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))
(if (local-alien-info-force-to-memory-p info)
- `(extract-alien-value var 0 ',alien-type)
- `(naturalize var ',alien-type))))
+ `(%alien-value var 0 ',alien-type)
+ `(naturalize var ',alien-type))))
(deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
- (unless (constant-continuation-p info)
- (abort-ir1-transform "Local alien info isn't constant?"))
- (let ((info (continuation-value info)))
+ (alien-info-constant-or-abort 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)
- (abort-ir1-transform "Local alien info isn't constant?"))
- (let* ((info (continuation-value info))
- (alien-type (local-alien-info-type info)))
+ (alien-info-constant-or-abort 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."))))
+ `(setf (%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))
- (alien-type (local-alien-info-type info)))
- (make-alien-type-type (make-alien-pointer-type :to alien-type)))
+ (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)
- (abort-ir1-transform "Local alien info isn't constant?"))
- (let* ((info (continuation-value info))
- (alien-type (local-alien-info-type info)))
+ (alien-info-constant-or-abort 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)
- `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
- (error "This shouldn't happen."))))
+ `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
+ (error "This shouldn't happen."))))
(deftransform dispose-local-alien ((info var) * * :important t)
- (unless (constant-continuation-p info)
- (abort-ir1-transform "Local alien info isn't constant?"))
- (let* ((info (continuation-value info))
- (alien-type (local-alien-info-type info)))
+ (alien-info-constant-or-abort 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
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits))
- #!-x86 `(%primitive dealloc-number-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits))
+ #!+(or x86 x86-64) `(%primitive dealloc-alien-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits))
+ #!-(or x86 x86-64) `(%primitive dealloc-number-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits))
nil)))
\f
;;;; %CAST
(defoptimizer (%cast derive-type) ((alien type))
- (or (when (constant-continuation-p type)
- (let ((alien-type (continuation-value type)))
- (when (alien-type-p alien-type)
- (make-alien-type-type alien-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))
- `(naturalize (alien-sap alien) ',target-type))
- (t
- (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
+ (alien-array-type-p target-type)
+ (alien-fun-type-p target-type))
+ `(naturalize (alien-sap alien) ',target-type))
+ (t
+ (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
\f
;;;; 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-function-args alien '%sap-alien 2)
+ (splice-fun-args alien '%sap-alien 2)
'(lambda (sap type)
- (declare (ignore type))
- sap))
+ (declare (ignore type))
+ sap))
(t
(give-up-ir1-transform)))))
(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)
;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
(flet ((%computed-lambda (compute-lambda type)
- (declare (type function compute-lambda))
- (unless (constant-continuation-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)
- result)
- (error (condition)
- (compiler-error "~A" condition)))))
+ (declare (type function compute-lambda))
+ (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 (lvar-value type))))
+ (/noshow "in %COMPUTED-LAMBDA" (lvar-value type) result)
+ result)
+ (error (condition)
+ (compiler-error "~A" condition)))))
(deftransform naturalize ((object type) * * :important t)
(%computed-lambda #'compute-naturalize-lambda type))
(deftransform deport ((alien type) * * :important t)
(%computed-lambda #'compute-deport-lambda type))
- (deftransform extract-alien-value ((sap offset type) * * :important t)
+ (deftransform deport-alloc ((alien type) * * :important t)
+ (%computed-lambda #'compute-deport-alloc-lambda type))
+ (deftransform %alien-value ((sap offset type) * * :important t)
(%computed-lambda #'compute-extract-lambda type))
- (deftransform deposit-alien-value ((sap offset type value) * * :important t)
+ (deftransform (setf %alien-value) ((value sap offset type) * * :important t)
(%computed-lambda #'compute-deposit-lambda type)))
\f
;;;; a hack to clean up divisions
(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-function-name (combination-fun thing))
+ (case (let ((name (lvar-fun-name (combination-fun thing))))
+ (or (modular-version-info name :untagged nil) name))
((+ -)
- (let ((min most-positive-fixnum)
- (itype (specifier-type 'integer)))
- (dolist (arg (combination-args thing) min)
- (if (csubtypep (continuation-type arg) itype)
- (setf min (min min (count-low-order-zeros arg)))
- (return 0)))))
+ (let ((min most-positive-fixnum)
+ (itype (specifier-type 'integer)))
+ (dolist (arg (combination-args thing) min)
+ (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)
- (setf result (+ result (count-low-order-zeros arg)))
- (return 0)))))
+ (let ((result 0)
+ (itype (specifier-type 'integer)))
+ (dolist (arg (combination-args thing) result)
+ (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)
- (max (+ (count-low-order-zeros (first args))
- (continuation-value amount))
- 0)
- 0))
- 0)))
+ (let ((args (combination-args thing)))
+ (if (= (length args) 2)
+ (let ((amount (second args)))
+ (if (constant-lvar-p amount)
+ (max (+ (count-low-order-zeros (first args))
+ (lvar-value amount))
+ 0)
+ 0))
+ 0)))
(t
- 0)))
+ 0)))
(integer
(if (zerop thing)
- most-positive-fixnum
- (do ((result 0 (1+ result))
- (num thing (ash num -1)))
- ((logbitp 0 num) result))))
+ most-positive-fixnum
+ (do ((result 0 (1+ result))
+ (num thing (ash num -1)))
+ ((logbitp 0 num) result))))
+ (cast
+ (count-low-order-zeros (cast-value thing)))
(t
0)))
(deftransform / ((numerator denominator) (integer integer))
- (unless (constant-continuation-p denominator)
+ "convert x/2^k to shift"
+ (unless (constant-lvar-p denominator)
(give-up-ir1-transform))
- (let* ((denominator (continuation-value denominator))
- (bits (1- (integer-length denominator))))
- (unless (= (ash 1 bits) denominator)
+ (let* ((denominator (lvar-value denominator))
+ (bits (1- (integer-length denominator))))
+ (unless (and (> denominator 0) (= (ash 1 bits) denominator))
(give-up-ir1-transform))
(let ((alignment (count-low-order-zeros numerator)))
(unless (>= alignment bits)
- (give-up-ir1-transform))
+ (give-up-ir1-transform))
`(ash numerator ,(- bits)))))
(deftransform ash ((value amount))
- (let ((value-node (continuation-use value)))
- (unless (and (combination-p value-node)
- (eq (continuation-function-name (combination-fun value-node))
- 'ash))
+ (let ((value-node (lvar-uses value)))
+ (unless (combination-p value-node)
(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))))
- (give-up-ir1-transform)))))
- (extract-function-args value 'ash 2)
- '(lambda (value amount1 amount2)
- (ash value (+ amount1 amount2))))
+ (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
+ (multiple-value-bind (prototype width)
+ (modular-version-info inside-fun-name :untagged nil)
+ (unless (eq (or prototype inside-fun-name) 'ash)
+ (give-up-ir1-transform))
+ (when (and width (not (constant-lvar-p amount)))
+ (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-lvar-p inside-amount)
+ (not (minusp (lvar-value inside-amount))))
+ (give-up-ir1-transform)))
+ (splice-fun-args value inside-fun-name 2)
+ (if width
+ `(lambda (value amount1 amount2)
+ (logand (ash value (+ amount1 amount2))
+ ,(1- (ash 1 (+ width (lvar-value amount))))))
+ `(lambda (value amount1 amount2)
+ (ash value (+ amount1 amount2)))))))))
\f
;;;; ALIEN-FUNCALL support
(deftransform alien-funcall ((function &rest args)
- ((alien (* t)) &rest *) *
- :important t)
+ ((alien (* t)) &rest *) *
+ :important t)
(let ((names (make-gensym-list (length args))))
(/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args)
`(lambda (function ,@names)
(alien-funcall (deref function) ,@names))))
-(deftransform alien-funcall ((function &rest args) * * :important t)
- (let ((type (continuation-type function)))
+(deftransform alien-funcall ((function &rest args) * * :node node :important t)
+ (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)
(let ((alien-type (alien-type-type-alien-type type)))
(unless (alien-fun-type-p alien-type)
- (give-up-ir1-transform))
+ (give-up-ir1-transform))
(let ((arg-types (alien-fun-type-arg-types alien-type)))
- (unless (= (length args) (length arg-types))
- (abort-ir1-transform
- "wrong number of arguments; expected ~D, got ~D"
- (length arg-types)
- (length args)))
- (collect ((params) (deports))
- (dolist (arg-type arg-types)
- (let ((param (gensym)))
- (params param)
- (deports `(deport ,param ',arg-type))))
- (let ((return-type (alien-fun-type-result-type alien-type))
- (body `(%alien-funcall (deport function ',alien-type)
- ',alien-type
- ,@(deports))))
- (if (alien-values-type-p return-type)
- (collect ((temps) (results))
- (dolist (type (alien-values-type-values return-type))
- (let ((temp (gensym)))
- (temps temp)
- (results `(naturalize ,temp ',type))))
- (setf body
- `(multiple-value-bind ,(temps) ,body
- (values ,@(results)))))
- (setf body `(naturalize ,body ',return-type)))
- (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
- `(lambda (function ,@(params))
- ,body)))))))
+ (unless (= (length args) (length arg-types))
+ (abort-ir1-transform
+ "wrong number of arguments; expected ~W, got ~W"
+ (length arg-types)
+ (length args)))
+ (collect ((params) (deports))
+ (dolist (arg-type arg-types)
+ (let ((param (gensym)))
+ (params param)
+ (deports `(deport ,param ',arg-type))))
+ ;; Build BODY from the inside out.
+ (let ((return-type (alien-fun-type-result-type alien-type))
+ ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
+ ;; to them) and do the call.
+ (body `(%alien-funcall (deport function ',alien-type)
+ ',alien-type
+ ,@(deports))))
+ ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
+ ;; the SAPs are taken for won't be moved by the GC. (If
+ ;; needed: some alien types won't need it).
+ (setf body `(maybe-with-pinned-objects ,(params) ,arg-types
+ ,body))
+ ;; Around that handle any memory allocation that's needed.
+ ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
+ ;; identity operation, but for example for deporting a
+ ;; Unicode string we need to convert the string into an
+ ;; octet array. This step needs to be done before the pinning
+ ;; to ensure we pin the right objects, so it can't be combined
+ ;; with the deporting.
+ ;; -- JES 2006-03-16
+ (loop for param in (params)
+ for arg-type in arg-types
+ do (setf body
+ `(let ((,param (deport-alloc ,param ',arg-type)))
+ ,body)))
+ (if (alien-values-type-p return-type)
+ (collect ((temps) (results))
+ (dolist (type (alien-values-type-values return-type))
+ (let ((temp (gensym)))
+ (temps temp)
+ (results `(naturalize ,temp ',type))))
+ (setf body
+ `(multiple-value-bind ,(temps) ,body
+ (values ,@(results)))))
+ (setf body `(naturalize ,body ',return-type)))
+ ;; Remember this frame to make sure that we can get back
+ ;; to it later regardless of how the foreign stack looks
+ ;; like.
+ #!+:c-stack-is-control-stack
+ (when (policy node (= 3 alien-funcall-saves-fp-and-pc))
+ (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body))))
+ (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
+ `(lambda (function ,@(params))
+ (declare (optimize (let-conversion 3)))
+ ,body)))))))
(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."))
- (specifier-type
+ (values-specifier-type
(compute-alien-rep-type
- (alien-fun-type-result-type type)))))
+ (alien-fun-type-result-type type)
+ :result))))
(defoptimizer (%alien-funcall ltn-annotate)
- ((function type &rest args) node ltn-policy)
+ ((function type &rest args) node ltn-policy)
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil)
- (annotate-ordinary-continuation function ltn-policy)
+ (annotate-ordinary-lvar function)
(dolist (arg args)
- (annotate-ordinary-continuation arg ltn-policy)))
+ (annotate-ordinary-lvar arg)))
+;;; We support both the stdcall and cdecl calling conventions on win32 by
+;;; resetting ESP after the foreign function returns. This way it works
+;;; correctly whether the party that is supposed to pop arguments from
+;;; the stack is the caller (cdecl) or the callee (stdcall).
(defoptimizer (%alien-funcall ir2-convert)
- ((function type &rest args) call block)
- (let ((type (if (constant-continuation-p type)
- (continuation-value type)
- (error "Something is broken.")))
- (cont (node-cont call))
- (args args))
+ ((function type &rest args) call block)
+ (let ((type (if (constant-lvar-p type)
+ (lvar-value type)
+ (error "Something is broken.")))
+ (lvar (node-lvar call))
+ (args args)
+ #!+x86
+ (stack-pointer (make-stack-pointer-tn)))
(multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
- (make-call-out-tns type)
+ (make-call-out-tns type)
+ #!+x86
+ (progn
+ (vop set-fpu-word-for-c call block)
+ (vop current-stack-pointer call block stack-pointer))
(vop alloc-number-stack-space call block stack-frame-size nsp)
(dolist (tn arg-tns)
- (let* ((arg (pop args))
- (sc (tn-sc tn))
- (scn (sc-number sc))
- #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn)
- scn))
- (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
- (aver arg)
- (unless (= (length move-arg-vops) 1)
- (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
- #!+x86 (emit-move-arg-template call
- block
- (first move-arg-vops)
- (continuation-tn call block arg)
- nsp
- tn)
- #!-x86 (progn
- (emit-move call
- block
- (continuation-tn call block arg)
- temp-tn)
- (emit-move-arg-template call
- block
- (first move-arg-vops)
- temp-tn
- nsp
- tn))))
+ ;; On PPC, TN might be a list. This is used to indicate
+ ;; something special needs to happen. See below.
+ ;;
+ ;; FIXME: We should implement something better than this.
+ (let* ((first-tn (if (listp tn) (car tn) tn))
+ (arg (pop args))
+ (sc (tn-sc first-tn))
+ (scn (sc-number sc))
+ #!-(or x86 x86-64) (temp-tn (make-representation-tn
+ (tn-primitive-type first-tn) scn))
+ (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
+ (aver arg)
+ (unless (= (length move-arg-vops) 1)
+ (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
+ #!+(or x86 x86-64) (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ (lvar-tn call block arg)
+ nsp
+ first-tn)
+ #!-(or x86 x86-64) (progn
+ (emit-move call
+ block
+ (lvar-tn call block arg)
+ temp-tn)
+ (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ temp-tn
+ nsp
+ first-tn))
+ #!+(and ppc darwin)
+ (when (listp tn)
+ ;; This means that we have a float arg that we need to
+ ;; also copy to some int regs. The list contains the TN
+ ;; for the float as well as the TNs to use for the int
+ ;; arg.
+ (destructuring-bind (float-tn i1-tn &optional i2-tn)
+ tn
+ (if i2-tn
+ (vop sb!vm::move-double-to-int-arg call block
+ float-tn i1-tn i2-tn)
+ (vop sb!vm::move-single-to-int-arg call block
+ float-tn i1-tn))))))
(aver (null args))
(unless (listp result-tns)
- (setf result-tns (list result-tns)))
- (vop* call-out call block
- ((continuation-tn call block function)
- (reference-tn-list arg-tns nil))
- ((reference-tn-list result-tns t)))
+ (setf result-tns (list result-tns)))
+ (let ((arg-tns (flatten-list arg-tns)))
+ (vop* call-out call block
+ ((lvar-tn call block function)
+ (reference-tn-list arg-tns nil))
+ ((reference-tn-list result-tns t))))
+ #!-x86
(vop dealloc-number-stack-space call block stack-frame-size)
- (move-continuation-result call block result-tns cont))))
+ #!+x86
+ (progn
+ (vop reset-stack-pointer call block stack-pointer)
+ (vop set-fpu-word-for-lisp call block))
+ (move-lvar-result call block result-tns lvar))))