[Sbcl-devel] structs as values in alien-function

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 454-5900

Hi

I really want structs as values in alien-funcall support in SBCL for
mac os x, x86 and ppc so I have tried to edit some of SBCLs code to
make that work.

I am currently working on x86 so I replaced the
  (deftransform alien-funcall ((function &rest args) * * :important t) ...)
in src/compiler/aliencomp.lisp with
  http://paste.lisp.org/display/44462#2

If I just run SBCL with SLIME and then evaluate that stuff from the
file it seems to work
for example, I can call

(define-alien-type nil
    (struct div_t
	    (quot int)
	    (rem int)))

(let ((res (alien-funcall
	    (extern-alien "div" (function (struct div_t) int int))
	    7 2)))
  (list (slot res 'quot)
	(slot res 'rem)))

and I get the correct result: (3 1)
(I've done other tests as well)

For some reason though I can't recompile SBCL with this change, it
rejects it (SBCL brakes into LDB).

Heres an extract from the build log:
[...
obj/from-xc/src/code/late-defbangmethod.lisp-obj
obj/from-xc/src/pcl/walk.lisp-obj
[building initial core file in "output/cold-sbcl.core":
writing 4096 bytes [1 page] from #<SB!FASL::GSPACE :READ-ONLY>
writing 4096 bytes [1 page] from #<SB!FASL::GSPACE :STATIC>
writing 39477248 bytes [9638 pages] from #<SB!FASL::GSPACE :DYNAMIC>
/(DESCRIPTOR-BITS INITIAL-FUN)=#X116B612D
done]
* //testing for consistency of first and second GENESIS passes
//header files match between first and second GENESIS -- good

real    3m19.853s
user    2m57.581s
sys     0m15.460s
//entering make-target-2.sh
//doing warm init - compilation phase
This is SBCL 1.0.7, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.

SBCL is free software, provided as is, with absolutely no warranty.
It is mostly in the public domain; some portions are provided under
BSD-style licenses.  See the CREDITS and COPYING files in the
distribution for more information.
fatal error encountered in SBCL pid 23574:
maximum interrupt nesting depth (32) exceeded

LDB monitor
ldb>
]

So hopefully someone can shed some light on the reason this is
happening, and are there any plans for adding structs as values
support to SBCL?

Thanks for your time,
here is the code again for reference:

(defun copy-struct-into-word-vector (struct struct-size-in-words)
  (let ((vector (make-array struct-size-in-words)))
    (loop for i from 0 to (1- struct-size-in-words)
       do (setf (elt vector i) (sb!sys:sap-ref-32 (alien-sap struct) (* i 4))))
    vector))

(defun splay-out-struct-parameter-types (arg-types)
  (mapcan #'(lambda (type)
              (if (alien-record-type-p type)
                  (loop repeat (ceiling
                                (alien-type-bits type)
                                sb!vm:n-word-bits)
                     collect (parse-alien-type
                              'unsigned-int
                              nil))
                  (list type)))
          arg-types))

(defun splay-struct-contents-to-word-sequences (params previous-arg-types body)
  (collect ((actual-params))
    (loop for type in previous-arg-types
       do (if (alien-record-type-p type)
              (let* ((size (ceiling (alien-type-bits type)
                                    sb!vm:n-word-bits))
                     (translation-params (subseq params 0 size)))
                (actual-params (car params))
                (setf params (subseq params size))
                (let ((i -1))
                  (setf body
                        `(let ((,(car translation-params)
                                (copy-struct-into-word-vector ,(car
translation-params) ,size)))
                           (let ,(mapcar
                                  #'(lambda (param)
                                      `(,param (elt ,(car
translation-params) ,(incf i))))
                                  translation-params)
                             ,body)))))
              (progn
                (actual-params (car params))
                (setf params (cdr params)))))
    (values (actual-params) body)))

(deftransform alien-funcall ((function &rest args) * * :important t)
  (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-fun-type-p alien-type)
        (give-up-ir1-transform))
      (let* ((arg-types (alien-fun-type-arg-types alien-type))
             (previous-arg-types arg-types))
        (unless (= (length args) (length arg-types))
          (abort-ir1-transform
           "wrong number of arguments; expected ~W, got ~W"
           (length arg-types)
           (length args)))
        ;; Build BODY from the inside out.
        (let ((return-type (alien-fun-type-result-type alien-type)))
              ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
              ;; to them) and do the call.
          (setf arg-types (splay-out-struct-parameter-types arg-types))
          (setf alien-type (make-alien-fun-type :result-type return-type
                                                :arg-types arg-types))
          (collect ((params) (deports))
            (dolist (arg-type arg-types)
              (let ((param (gensym)))
                (params param)
                (deports `(deport ,param ',arg-type))))
            (let ((body `(%alien-funcall (deport function ',alien-type)
                                         ',alien-type
                                         ,@(deports))))
              ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
              ;; the SAPs are taken for won't be moved by the GC. (If
              ;; needed: some alien types won't need it).
              (setf body `(maybe-with-pinned-objects ,(params) ,arg-types
                            ,body))
              ;; Around that handle any memory allocation that's needed.
              ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
              ;; identity operation, but for example for deporting a
              ;; Unicode string we need to convert the string into an
              ;; octet array. This step needs to be done before the pinning
              ;; to ensure we pin the right objects, so it can't be combined
              ;; with the deporting.
              ;; -- JES 2006-03-16
              (loop for param in (params)
                    for arg-type in arg-types
                    do (setf body
                             `(let ((,param (deport-alloc ,param ',arg-type)))
                                ,body)))
              (if (alien-values-type-p return-type)
                  (collect ((temps) (results))
                    (dolist (type (alien-values-type-values return-type))
                      (let ((temp (gensym)))
                        (temps temp)
                        (results `(naturalize ,temp ',type))))
                    (setf body
                          `(multiple-value-bind ,(temps) ,body
                             (values ,@(results)))))
                  (setf body `(naturalize ,body ',return-type)))
              (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL"
(params) body)
              (multiple-value-bind (actual-params body)
                  (splay-struct-contents-to-word-sequences (params)
previous-arg-types body)
                `(lambda (function ,@actual-params)
                   (setf function (make-alien-value :sap
(alien-value-sap function)
                                                    :type ,alien-type))
                   ,body)))))))))

[Sbcl-devel] structs as values in alien-function

Common Lisp compiler and runtime

[Sbcl-devel] structs as values in alien-function