X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=89771f2ebeb6acc86bab51fc74f69f0f3355aa29;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=7c2fbc0b6b1fc23b33211b1c046f689ded5a6dbf;hpb=a18f0a95bc9a457e4d2d00c702b746f29c2662b1;p=sbcl.git diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 7c2fbc0..89771f2 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -61,14 +61,13 @@ (flushable movable)) (defknown deport (alien alien-type) t (flushable movable)) -(defknown extract-alien-value (system-area-pointer index alien-type) t +(defknown extract-alien-value (system-area-pointer unsigned-byte alien-type) t (flushable)) -(defknown deposit-alien-value (system-area-pointer index alien-type t) t +(defknown deposit-alien-value (system-area-pointer unsigned-byte alien-type t) t ()) (defknown alien-funcall (alien-value &rest *) * (any recursive)) -(defknown %alien-funcall (system-area-pointer alien-type &rest *) *) ;;;; cosmetic transforms @@ -87,16 +86,16 @@ ;;;; SLOT support (defun find-slot-offset-and-type (alien slot) - (unless (constant-continuation-p slot) + (unless (constant-lvar-p slot) (give-up-ir1-transform "The slot is not constant, so access cannot be open coded.")) - (let ((type (continuation-type alien))) + (let ((type (lvar-type alien))) (unless (alien-type-type-p type) (give-up-ir1-transform)) (let ((alien-type (alien-type-type-alien-type type))) (unless (alien-record-type-p alien-type) (give-up-ir1-transform)) - (let* ((slot-name (continuation-value slot)) + (let* ((slot-name (lvar-value slot)) (field (find slot-name (alien-record-type-fields alien-type) :key #'alien-record-field-name))) (unless field @@ -131,7 +130,7 @@ (find-slot-offset-and-type alien slot) (declare (ignore slot-offset)) (let ((type (make-alien-type-type slot-type))) - (assert-continuation-type value type) + (assert-lvar-type value type) (return type)))) *wild-type*)) @@ -157,13 +156,13 @@ (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 (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))) @@ -186,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 @@ -253,7 +252,7 @@ (let ((type (make-alien-type-type (make-alien-pointer-type :to (find-deref-element-type alien))))) - (assert-continuation-type value type) + (assert-lvar-type value type) (return type))) *wild-type*)) @@ -280,15 +279,15 @@ (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 (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)))) @@ -312,7 +311,7 @@ (multiple-value-bind (sap type) (heap-alien-sap-and-type info) (declare (ignore sap)) (let ((type (make-alien-type-type type))) - (assert-continuation-type value type) + (assert-lvar-type value type) (return type)))) *wild-type*)) @@ -336,9 +335,9 @@ ;;;; support for local (stack or register) aliens (deftransform make-local-alien ((info) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info)) (bits (alien-type-bits alien-type))) (unless bits @@ -347,14 +346,14 @@ (/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 + #!+(or x86 x86-64) `(truly-the system-area-pointer (%primitive alloc-alien-stack-space ,(ceiling (alien-type-bits alien-type) - sb!vm:byte-bits))) - #!-x86 `(truly-the system-area-pointer + sb!vm:n-byte-bits))) + #!-(or x86 x86-64) `(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) @@ -371,13 +370,13 @@ (deftransform note-local-alien-type ((info var) * * :important t) ;; FIXME: This test and error occur about a zillion times. They ;; could be factored into a function. - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let ((info (continuation-value info))) + (let ((info (lvar-value info))) (/noshow "in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info) (/noshow (local-alien-info-force-to-memory-p info)) (unless (local-alien-info-force-to-memory-p info) - (let ((var-node (continuation-use var))) + (let ((var-node (lvar-uses var))) (/noshow var-node (ref-p var-node)) (when (ref-p var-node) (propagate-to-refs (ref-leaf var-node) @@ -387,9 +386,9 @@ nil) (deftransform local-alien ((info var) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type) (/noshow (local-alien-info-force-to-memory-p info)) @@ -398,31 +397,31 @@ `(naturalize var ',alien-type)))) (deftransform %local-alien-forced-to-memory-p ((info) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let ((info (continuation-value info))) + (let ((info (lvar-value info))) (local-alien-info-force-to-memory-p info))) (deftransform %set-local-alien ((info var value) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (if (local-alien-info-force-to-memory-p info) `(deposit-alien-value var 0 ',alien-type value) '(error "This should be eliminated as dead code.")))) (defoptimizer (%local-alien-addr derive-type) ((info var)) - (if (constant-continuation-p info) - (let* ((info (continuation-value info)) + (if (constant-lvar-p info) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (make-alien-type-type (make-alien-pointer-type :to alien-type))) *wild-type*)) (deftransform %local-alien-addr ((info var) * * :important t) - (unless (constant-continuation-p info) + (unless (constant-lvar-p info) (abort-ir1-transform "Local alien info isn't constant?")) - (let* ((info (continuation-value info)) + (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN") (if (local-alien-info-force-to-memory-p info) @@ -430,36 +429,36 @@ (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 + #!+(or x86 x86-64) `(%primitive dealloc-alien-stack-space ,(ceiling (alien-type-bits alien-type) - sb!vm:byte-bits)) - #!-x86 `(%primitive dealloc-number-stack-space + sb!vm:n-byte-bits)) + #!-(or x86 x86-64) `(%primitive dealloc-number-stack-space ,(ceiling (alien-type-bits alien-type) - sb!vm:byte-bits)) + sb!vm:n-byte-bits)) nil))) ;;;; %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-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))))) @@ -467,10 +466,10 @@ ;;;; 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) + (extract-fun-args alien '%sap-alien 2) '(lambda (sap type) (declare (ignore type)) sap)) @@ -479,8 +478,8 @@ (defoptimizer (%sap-alien derive-type) ((sap type)) (declare (ignore sap)) - (if (constant-continuation-p type) - (make-alien-type-type (continuation-value type)) + (if (constant-lvar-p type) + (make-alien-type-type (lvar-value type)) *wild-type*)) (deftransform %sap-alien ((sap type) * * :important t) @@ -494,12 +493,12 @@ (flet ((%computed-lambda (compute-lambda type) (declare (type function compute-lambda)) - (unless (constant-continuation-p type) + (unless (constant-lvar-p type) (give-up-ir1-transform "The type is not constant at compile time; can't open code.")) (handler-case - (let ((result (funcall compute-lambda (continuation-value type)))) - (/noshow "in %COMPUTED-LAMBDA" (continuation-value type) result) + (let ((result (funcall compute-lambda (lvar-value type)))) + (/noshow "in %COMPUTED-LAMBDA" (lvar-value type) result) result) (error (condition) (compiler-error "~A" condition))))) @@ -516,33 +515,34 @@ (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 :unsigned) name)) ((+ -) (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))) @@ -554,15 +554,18 @@ (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)) + (let* ((denominator (lvar-value denominator)) (bits (1- (integer-length denominator)))) - (unless (= (ash 1 bits) denominator) + (unless (and (> denominator 0) (= (ash 1 bits) denominator)) (give-up-ir1-transform)) (let ((alignment (count-low-order-zeros numerator))) (unless (>= alignment bits) @@ -570,21 +573,30 @@ `(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 :unsigned) + (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))) + (extract-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))))))))) ;;;; ALIEN-FUNCALL support @@ -597,17 +609,17 @@ (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) (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)) @@ -615,7 +627,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)))) @@ -635,29 +647,29 @@ (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))) - (unless (alien-function-type-p 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-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-lvar function) (dolist (arg args) - (annotate-ordinary-continuation arg ltn-policy))) + (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) @@ -666,22 +678,22 @@ (let* ((arg (pop args)) (sc (tn-sc tn)) (scn (sc-number sc)) - #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn) + #!-(or x86 x86-64) (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 + #!+(or x86 x86-64) (emit-move-arg-template call block (first move-arg-vops) - (continuation-tn call block arg) + (lvar-tn call block arg) nsp tn) - #!-x86 (progn + #!-(or x86 x86-64) (progn (emit-move call block - (continuation-tn call block arg) + (lvar-tn call block arg) temp-tn) (emit-move-arg-template call block @@ -693,8 +705,8 @@ (unless (listp result-tns) (setf result-tns (list result-tns))) (vop* call-out call block - ((continuation-tn call block function) + ((lvar-tn call block function) (reference-tn-list arg-tns nil)) ((reference-tn-list result-tns t))) (vop dealloc-number-stack-space call block stack-frame-size) - (move-continuation-result call block result-tns cont)))) + (move-lvar-result call block result-tns lvar))))