X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=85f2b1afb3c80bd606f5790348a31cf6b23779a5;hb=8a19c6876412b8ad1cf729297c2a373d63a0d0ec;hp=ce650192edddbf9acd6815d2bc82f77ff735bb04;hpb=c9c0e648c51317ff374851c4fcc740a15d37acae;p=sbcl.git diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index ce65019..85f2b1a 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") ;;;; DEFKNOWNs @@ -71,7 +68,6 @@ (defknown alien-funcall (alien-value &rest *) * (any recursive)) -(defknown %alien-funcall (system-area-pointer alien-type &rest *) *) ;;;; cosmetic transforms @@ -160,7 +156,7 @@ (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)))) ;;;; DEREF support @@ -189,7 +185,7 @@ (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 @@ -283,7 +279,7 @@ (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))))) ;;;; support for aliens on the heap @@ -353,11 +349,11 @@ #!+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) @@ -387,7 +383,7 @@ (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) @@ -440,10 +436,10 @@ (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))) ;;;; %CAST @@ -462,7 +458,7 @@ (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))))) @@ -473,7 +469,7 @@ (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)) @@ -488,6 +484,8 @@ (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")) @@ -522,7 +520,7 @@ (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))) @@ -573,7 +571,7 @@ (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))) @@ -583,7 +581,7 @@ (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)))) @@ -603,12 +601,12 @@ (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)) @@ -616,7 +614,7 @@ (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)))) @@ -639,19 +637,19 @@ (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 (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 policy) + ((function type &rest args) node ltn-policy) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil) - (annotate-ordinary-continuation function policy) + (annotate-ordinary-continuation function ltn-policy) (dolist (arg args) - (annotate-ordinary-continuation arg policy))) + (annotate-ordinary-continuation arg ltn-policy))) (defoptimizer (%alien-funcall ir2-convert) ((function type &rest args) call block) @@ -670,10 +668,9 @@ #!-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) @@ -691,7 +688,7 @@ 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