(defknown alien-funcall (alien-value &rest *) *
(any recursive))
-(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
\f
;;;; cosmetic transforms
(multiple-value-bind (slot-offset slot-type)
(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:byte-bits))
+ `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb!vm:n-byte-bits))
',(make-alien-pointer-type :to slot-type))))
\f
;;;; DEREF support
(typecase alien-type
(alien-pointer-type
(when (cdr indices)
- (abort-ir1-transform "too many indices for pointer deref: ~D"
+ (abort-ir1-transform "too many indices for pointer deref: ~W"
(length indices)))
(let ((element-type (alien-pointer-type-to alien-type)))
(if indices
(compute-deref-guts alien indices)
(/noshow "in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
`(lambda (alien ,@indices-args)
- (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb!vm:byte-bits))
+ (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb!vm:n-byte-bits))
',(make-alien-pointer-type :to element-type)))))
\f
;;;; support for aliens on the heap
#!+x86 `(truly-the system-area-pointer
(%primitive alloc-alien-stack-space
,(ceiling (alien-type-bits alien-type)
- sb!vm:byte-bits)))
+ sb!vm:n-byte-bits)))
#!-x86 `(truly-the system-area-pointer
(%primitive alloc-number-stack-space
,(ceiling (alien-type-bits alien-type)
- sb!vm:byte-bits)))
+ 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)
(specifier-type
(compute-alien-rep-type
(local-alien-info-type info))))))))
- 'nil)
+ nil)
(deftransform local-alien ((info var) * * :important t)
(unless (constant-continuation-p info)
(if (local-alien-info-force-to-memory-p info)
#!+x86 `(%primitive dealloc-alien-stack-space
,(ceiling (alien-type-bits alien-type)
- sb!vm:byte-bits))
+ sb!vm:n-byte-bits))
#!-x86 `(%primitive dealloc-number-stack-space
,(ceiling (alien-type-bits alien-type)
- sb!vm:byte-bits))
+ sb!vm:n-byte-bits))
nil)))
\f
;;;; %CAST
(let ((target-type (continuation-value target-type)))
(cond ((or (alien-pointer-type-p target-type)
(alien-array-type-p target-type)
- (alien-function-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)))))
(let ((alien-node (continuation-use alien)))
(typecase alien-node
(combination
- (extract-function-args alien '%sap-alien 2)
+ (extract-fun-args alien '%sap-alien 2)
'(lambda (sap type)
(declare (ignore type))
sap))
(deftransform %sap-alien ((sap type) * * :important t)
(give-up-ir1-transform
+ ;; FIXME: The hardcoded newline here causes more-than-usually
+ ;; screwed-up formatting of the optimization note output.
"could not optimize away %SAP-ALIEN: forced to do runtime ~@
allocation of alien-value structure"))
\f
(count-low-order-zeros (continuation-value thing))
(count-low-order-zeros (continuation-use thing))))
(combination
- (case (continuation-function-name (combination-fun thing))
+ (case (continuation-fun-name (combination-fun thing))
((+ -)
(let ((min most-positive-fixnum)
(itype (specifier-type 'integer)))
(deftransform ash ((value amount))
(let ((value-node (continuation-use value)))
(unless (and (combination-p value-node)
- (eq (continuation-function-name (combination-fun value-node))
+ (eq (continuation-fun-name (combination-fun value-node))
'ash))
(give-up-ir1-transform))
(let ((inside-args (combination-args value-node)))
(unless (and (constant-continuation-p inside-amount)
(not (minusp (continuation-value inside-amount))))
(give-up-ir1-transform)))))
- (extract-function-args value 'ash 2)
+ (extract-fun-args value 'ash 2)
'(lambda (value amount1 amount2)
(ash value (+ amount1 amount2))))
\f
(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-function-type-p alien-type)
+ (unless (alien-fun-type-p alien-type)
(give-up-ir1-transform))
- (let ((arg-types (alien-function-type-arg-types alien-type)))
+ (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"
+ "wrong number of arguments; expected ~W, got ~W"
(length arg-types)
(length args)))
(collect ((params) (deports))
(let ((param (gensym)))
(params param)
(deports `(deport ,param ',arg-type))))
- (let ((return-type (alien-function-type-result-type alien-type))
+ (let ((return-type (alien-fun-type-result-type alien-type))
(body `(%alien-funcall (deport function ',alien-type)
',alien-type
,@(deports))))
(unless (constant-continuation-p type)
(error "Something is broken."))
(let ((type (continuation-value type)))
- (unless (alien-function-type-p type)
+ (unless (alien-fun-type-p type)
(error "Something is broken."))
- (specifier-type
+ (values-specifier-type
(compute-alien-rep-type
- (alien-function-type-result-type type)))))
+ (alien-fun-type-result-type type)))))
(defoptimizer (%alien-funcall ltn-annotate)
((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-continuation function)
(dolist (arg args)
- (annotate-ordinary-continuation arg ltn-policy)))
+ (annotate-ordinary-continuation arg)))
(defoptimizer (%alien-funcall ir2-convert)
((function type &rest args) call block)
#!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn)
scn))
(move-arg-vops (svref (sc-move-arg-vops sc) scn)))
- (assert arg)
- (assert (= (length move-arg-vops) 1) ()
- "no unique move-arg-vop for moves in SC ~S"
- (sc-name sc))
+ (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)
temp-tn
nsp
tn))))
- (assert (null args))
+ (aver (null args))
(unless (listp result-tns)
(setf result-tns (list result-tns)))
(vop* call-out call block