Menu
▾
▴
[Sbcl-commits] master: sb-alien: some alien refactoring
|
From: Nikodemus S. <de...@us...> - 2012-06-09 13:14:02
|
The branch "master" has been updated in SBCL:
via a0773e7d643c53e8626e49a560fb2b5ba6d8790e (commit)
from 3352db3a8b45bc544473915ef25a4708f386be36 (commit)
- Log -----------------------------------------------------------------
commit a0773e7d643c53e8626e49a560fb2b5ba6d8790e
Author: Nikodemus Siivola <nik...@ra...>
Date: Sat Mar 31 12:28:06 2012 +0300
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.
---
package-data-list.lisp-expr | 6 +-
src/code/describe.lisp | 2 +-
src/code/host-alieneval.lisp | 26 +++++++---
src/code/target-alieneval.lisp | 109 +++++++++++++++++++++-------------------
src/compiler/aliencomp.lisp | 46 ++++++++--------
5 files changed, 104 insertions(+), 85 deletions(-)
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
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|