From: Nikodemus Siivola Date: Sat, 31 Mar 2012 09:28:06 +0000 (+0300) Subject: sb-alien: some alien refactoring X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a0773e7d643c53e8626e49a560fb2b5ba6d8790e;p=sbcl.git sb-alien: some alien refactoring * Rename EXTRACT-ALIEN-VALUE & DEPOSIT-ALIEN-VALUE to %ALIEN-VALUE and (SETF %ALIEN-VALUE). * Split HEAP-ALIEN-INFO-SAP-FORM field into HEAP-ALIEN-INFO-ALIEN-NAME and -DATAP. HEAP-ALIEN-INFO-SAP-FORM becomes a function that conses up the form for the compiler, and HEAP-ALIEN-INFO-SAP replaces EVAL of the form. * Better error checking in PICK-LISP-AND-ALIEN-NAMES, and an error message that explains the correct form. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 1cc6e99..790a51a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -71,7 +71,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" :name "SB!ALIEN-INTERNALS" :doc "private: stuff for implementing ALIENs and friends" :use ("CL") - :export ("%CAST" + :export ("%ALIEN-VALUE" + "%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR" "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" @@ -109,9 +110,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "COMPUTE-NATURALIZE-LAMBDA" "DEFINE-ALIEN-TYPE-CLASS" "DEFINE-ALIEN-TYPE-METHOD" "DEFINE-ALIEN-TYPE-TRANSLATOR" "DEPORT" "DEPORT-ALLOC" - "DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN" + "DISPOSE-LOCAL-ALIEN" "*ENTER-ALIEN-CALLBACK*" "ENTER-ALIEN-CALLBACK" - "EXTRACT-ALIEN-VALUE" "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM" "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN" "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P" diff --git a/src/code/describe.lisp b/src/code/describe.lisp index ddff875..17dc2fb 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -270,7 +270,7 @@ (sb-alien-internals:unparse-alien-type (sb-alien::heap-alien-info-type info))) (format stream "~@:_Address: #x~8,'0X" - (sap-int (eval (sb-alien::heap-alien-info-sap-form info)))))) + (sap-int (sb-alien::heap-alien-info-sap info))))) ((eq kind :macro) (let ((expansion (info :variable :macro-expansion symbol))) (format stream "~@:_Expansion: ~S" expansion))) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index c29bdd5..1f554c6 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -404,15 +404,27 @@ (:make-load-form-fun sb!kernel:just-dump-it-normally)) ;; The type of this alien. (type (missing-arg) :type alien-type) - ;; The form to evaluate to produce the SAP pointing to where in the heap - ;; it is. - (sap-form (missing-arg))) + ;; Its name. + (alien-name (missing-arg) :type simple-string) + ;; Data or code? + (datap (missing-arg) :type boolean)) (def!method print-object ((info heap-alien-info) stream) (print-unreadable-object (info stream :type t) - (funcall (formatter "~S ~S") + (funcall (formatter "~S ~S~@[ (data)~]") stream - (heap-alien-info-sap-form info) - (unparse-alien-type (heap-alien-info-type info))))) + (heap-alien-info-alien-name info) + (unparse-alien-type (heap-alien-info-type info)) + (heap-alien-info-datap info)))) + +;;; The form to evaluate to produce the SAP pointing to where in the heap +;;; it is. +(defun heap-alien-info-sap-form (info) + `(foreign-symbol-sap ,(heap-alien-info-alien-name info) + ,(heap-alien-info-datap info))) + +(defun heap-alien-info-sap (info) + (foreign-symbol-sap (heap-alien-info-alien-name info) + (heap-alien-info-datap info))) ;;;; Interfaces to the different methods @@ -484,7 +496,7 @@ (defun compute-deposit-lambda (type) (declare (type alien-type type)) - `(lambda (sap offset ignore value) + `(lambda (value sap offset ignore) (declare (type system-area-pointer sap) (type unsigned-byte offset) (ignore ignore)) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index c66e364..7e9b25e 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -35,22 +35,32 @@ ;;; guess the other. (eval-when (:compile-toplevel :load-toplevel :execute) (defun pick-lisp-and-alien-names (name) - (etypecase name - (string - (values (guess-lisp-name-from-alien-name name) name)) - (symbol - (values name (guess-alien-name-from-lisp-name name))) - (list - (unless (proper-list-of-length-p name 2) - (error "badly formed alien name")) - (values (cadr name) (car name)))))) + (flet ((oops () + (error "~@<~:IMalformed alien name. Acceptable formats are:~ + ~:@_ (\"alien_name\" LISP-NAME)~ + ~:@_ FOO-BAR - equivalent to (\"foo_bar\" FOO-BAR)~ + ~:@_ \"foo_bar\" - equivalent to (\"foo_bar\" FOO-BAR)~:@>"))) + (etypecase name + (string + (values (guess-lisp-name-from-alien-name name) + (coerce name 'simple-string))) + (symbol + (values name (guess-alien-name-from-lisp-name name))) + (list + (unless (and (proper-list-of-length-p name 2) + (symbolp (second name)) + (stringp (first name))) + (oops)) + (values (second name) (coerce (first name) 'simple-string))) + (t + (oops)))))) (defmacro define-alien-variable (name type &environment env) #!+sb-doc - "Define NAME as an external alien variable of type TYPE. NAME should be - a list of a string holding the alien name and a symbol to use as the Lisp - name. If NAME is just a symbol or string, then the other name is guessed - from the one supplied." + "Define NAME as an external alien variable of type TYPE. NAME should +be a list of a string holding the alien name and a symbol to use as +the Lisp name. If NAME is just a symbol or string, then the other name +is guessed from the one supplied." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) (with-auxiliary-alien-types env (let ((alien-type (parse-alien-type type env))) @@ -68,7 +78,8 @@ (setf (info :variable :where-from lisp-name) :defined) (setf (info :variable :alien-info lisp-name) (make-heap-alien-info :type type - :sap-form `(foreign-symbol-sap ',alien-name t))))) + :alien-name alien-name + :datap t)))) (defun alien-value (symbol) #!+sb-doc @@ -80,16 +91,14 @@ variable is undefined." (defmacro extern-alien (name type &environment env) #!+sb-doc - "Access the alien variable named NAME, assuming it is of type TYPE. This - is SETFable." + "Access the alien variable named NAME, assuming it is of type TYPE. +This is SETFable." (let* ((alien-name (etypecase name (symbol (guess-alien-name-from-lisp-name name)) (string name))) (alien-type (parse-alien-type type env)) (datap (not (alien-fun-type-p alien-type)))) - `(%heap-alien ',(make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',alien-name ,datap))))) + `(%alien-value (foreign-symbol-sap ,alien-name ,datap) 0 ',alien-type))) (defmacro with-alien (bindings &body body &environment env) #!+sb-doc @@ -144,13 +153,11 @@ variable is undefined." ,@body))))) (:extern (/show0 ":EXTERN case") - (let ((info (make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',initial-value - ,datap)))) - `((symbol-macrolet - ((,symbol (%heap-alien ',info))) - ,@body)))) + `((symbol-macrolet + ((,symbol + (%alien-value + (foreign-symbol-sap ,initial-value ,datap) 0 ,alien-type))) + ,@body))) (:local (/show0 ":LOCAL case") (let* ((var (sb!xc:gensym "VAR")) @@ -399,9 +406,9 @@ null byte. (slot (deref alien) slot)) (alien-record-type (let ((field (slot-or-lose type slot))) - (extract-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field))))))) + (%alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field))))))) ;;; Deposit the value in the specified slot of the record ALIEN. If ;;; the ALIEN is really a pointer, DEREF it first. The compiler uses @@ -416,10 +423,10 @@ null byte. (%set-slot (deref alien) slot value)) (alien-record-type (let ((field (slot-or-lose type slot))) - (deposit-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field) - value)))))) + (setf (%alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field)) + value)))))) ;;; Compute the address of the specified slot and return a pointer to it. (defun %slot-addr (alien slot) @@ -489,19 +496,19 @@ null byte. (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (extract-alien-value (alien-value-sap alien) - offset - target-type))) + (%alien-value (alien-value-sap alien) + offset + target-type))) (defun %set-deref (alien value &rest indices) (declare (type alien-value alien) (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (deposit-alien-value (alien-value-sap alien) - offset - target-type - value))) + (setf (%alien-value (alien-value-sap alien) + offset + target-type) + value))) (defun %deref-addr (alien &rest indices) (declare (type alien-value alien) @@ -516,22 +523,22 @@ null byte. (defun %heap-alien (info) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (extract-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info))) + (%alien-value (heap-alien-info-sap info) + 0 + (heap-alien-info-type info))) (defun %set-heap-alien (info value) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (deposit-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info) - value)) + (setf (%alien-value (heap-alien-info-sap info) + 0 + (heap-alien-info-type info)) + value)) (defun %heap-alien-addr (info) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (%sap-alien (eval (heap-alien-info-sap-form info)) + (%sap-alien (heap-alien-info-sap info) (make-alien-pointer-type :to (heap-alien-info-type info)))) ;;;; accessing local aliens @@ -657,19 +664,19 @@ null byte. (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type)) value type)) -(defun extract-alien-value (sap offset type) +(defun %alien-value (sap offset type) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) (funcall (coerce-to-interpreted-function (compute-extract-lambda type)) sap offset type)) -(defun deposit-alien-value (sap offset type value) +(defun (setf %alien-value) (value sap offset type) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) (funcall (coerce-to-interpreted-function (compute-deposit-lambda type)) - sap offset type value)) + value sap offset type)) ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 36226af..56903ce 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -63,9 +63,9 @@ (flushable movable)) (defknown deport-alloc (alien alien-type) t (flushable movable)) -(defknown extract-alien-value (system-area-pointer unsigned-byte alien-type) t +(defknown %alien-value (system-area-pointer unsigned-byte alien-type) t (flushable)) -(defknown deposit-alien-value (system-area-pointer unsigned-byte alien-type t) t +(defknown (setf %alien-value) (t system-area-pointer unsigned-byte alien-type) t ()) (defknown alien-funcall (alien-value &rest *) * @@ -120,9 +120,9 @@ (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)) @@ -139,10 +139,10 @@ (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 @@ -244,9 +244,9 @@ (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)) @@ -264,10 +264,10 @@ (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)) @@ -304,9 +304,9 @@ (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)) @@ -321,7 +321,7 @@ (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 @@ -397,7 +397,7 @@ (/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) + `(%alien-value var 0 ',alien-type) `(naturalize var ',alien-type)))) (deftransform %local-alien-forced-to-memory-p ((info) * * :important t) @@ -410,7 +410,7 @@ (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) + `(setf (%alien-value var 0 ',alien-type) value) '(error "This should be eliminated as dead code.")))) (defoptimizer (%local-alien-addr derive-type) ((info var)) @@ -508,9 +508,9 @@ (%computed-lambda #'compute-deport-lambda type)) (deftransform deport-alloc ((alien type) * * :important t) (%computed-lambda #'compute-deport-alloc-lambda type)) - (deftransform extract-alien-value ((sap offset type) * * :important t) + (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))) ;;;; a hack to clean up divisions