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 (file)
--- 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 (file)
--- 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 (file)
--- 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)))
 \f
 ;;;; 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 (file)
--- 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))))
 \f
 ;;;; 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))
 \f
 ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
 

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 36226af..56903ce 100644 (file)
--- 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)))
 \f
 ;;;; a hack to clean up divisions