mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
b0ca878cae
* libguile/foreign.c: Convert to using RTL stubs. Because RTL code has
different GC characteristics than objcode -- it's mostly assumed that
RTL code will never go away -- we go ahead and pre-generate code for
100 arguments. This is actually less memory than the stack VM code,
and doesn't require any relocations at load-time: bonus! We'll cross
the >=100 args bridge if we ever come to it.
(get_foreign_stub_code) New function.
(scm_i_foreign_arity): New helper, like scm_i_primitive_arity.
(cif_to_procedure): Rework to make RTL programs.
* libguile/foreign.h: Declare scm_pointer_to_scm and
scm_scm_to_pointer. Declare new internal helpers.
* libguile/gsubr.c (create_subr): Refactor to set the flags when the
object is allocated.
* libguile/instructions.h: Define SCM_PACK_RTL_12_12.
* libguile/programs.c (scm_i_rtl_program_minimum_arity): Dispatch to
scm_i_foreign_arity if the procedure has the FOREIGN flag.
* libguile/programs.h (SCM_F_PROGRAM_IS_FOREIGN)
(SCM_PROGRAM_IS_FOREIGN): New interfaces.
* test-suite/tests/foreign.test ("procedure->pointer"): Add a test for
foreign arities.
411 lines
14 KiB
Scheme
411 lines
14 KiB
Scheme
;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
|
||
;;;;
|
||
;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
|
||
;;;;
|
||
;;;; This library is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free Software
|
||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
;;;
|
||
;;; See also ../standalone/test-ffi for FFI tests.
|
||
;;;
|
||
|
||
(define-module (test-foreign)
|
||
#:use-module (system foreign)
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (ice-9 format)
|
||
#:use-module (test-suite lib))
|
||
|
||
|
||
(with-test-prefix "dynamic-pointer"
|
||
|
||
(pass-if-exception
|
||
"error message"
|
||
'(misc-error . "^Symbol not found")
|
||
(dynamic-func "does_not_exist___" (dynamic-link))))
|
||
|
||
|
||
(with-test-prefix "null pointer"
|
||
|
||
(pass-if "pointer?"
|
||
(pointer? %null-pointer))
|
||
|
||
(pass-if "zero"
|
||
(= 0 (pointer-address %null-pointer)))
|
||
|
||
(pass-if "null pointer identity"
|
||
(eq? %null-pointer (make-pointer 0)))
|
||
|
||
(pass-if "null-pointer? %null-pointer"
|
||
(null-pointer? %null-pointer))
|
||
|
||
(pass-if-exception "dereference-pointer %null-pointer"
|
||
exception:null-pointer-error
|
||
(dereference-pointer %null-pointer))
|
||
|
||
(pass-if-exception "pointer->bytevector %null-pointer"
|
||
exception:null-pointer-error
|
||
(pointer->bytevector %null-pointer 7)))
|
||
|
||
|
||
(with-test-prefix "make-pointer"
|
||
|
||
(pass-if "pointer?"
|
||
(pointer? (make-pointer 123)))
|
||
|
||
(pass-if "address preserved"
|
||
(= 123 (pointer-address (make-pointer 123))))
|
||
|
||
(pass-if "equal?"
|
||
(equal? (make-pointer 123) (make-pointer 123)))
|
||
|
||
(pass-if "equal? modulo finalizer"
|
||
(let ((finalizer (false-if-exception
|
||
(dynamic-func "scm_is_pair" (dynamic-link)))))
|
||
(if (not finalizer)
|
||
(throw 'unresolved) ; Windows or a static build
|
||
(equal? (make-pointer 123)
|
||
(make-pointer 123 finalizer)))))
|
||
|
||
(pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
|
||
(let ((finalizer (false-if-exception
|
||
(dynamic-func "scm_is_pair" (dynamic-link))))
|
||
(ptr (make-pointer 123)))
|
||
(if (not finalizer)
|
||
(throw 'unresolved) ; Windows or a static build
|
||
(begin
|
||
(set-pointer-finalizer! ptr finalizer)
|
||
(equal? (make-pointer 123) ptr)))))
|
||
|
||
(pass-if "not equal?"
|
||
(not (equal? (make-pointer 123) (make-pointer 456)))))
|
||
|
||
|
||
(with-test-prefix "pointer<->scm"
|
||
|
||
(pass-if "immediates"
|
||
(equal? (pointer->scm (scm->pointer #\newline))
|
||
#\newline))
|
||
|
||
(pass-if "non-immediates"
|
||
(equal? (pointer->scm (scm->pointer "Hello, world!"))
|
||
"Hello, world!")))
|
||
|
||
|
||
(define-wrapped-pointer-type foo
|
||
foo?
|
||
wrap-foo unwrap-foo
|
||
(lambda (x p)
|
||
(format p "#<foo! ~a>" (pointer-address (unwrap-foo x)))))
|
||
|
||
(with-test-prefix "define-wrapped-pointer-type"
|
||
|
||
(pass-if "foo?"
|
||
(foo? (wrap-foo %null-pointer)))
|
||
|
||
(pass-if "unwrap-foo"
|
||
(let ((p (make-pointer 123)))
|
||
(eq? p (unwrap-foo (wrap-foo p)))))
|
||
|
||
(pass-if "identity"
|
||
(let ((p1 (make-pointer 123))
|
||
(p2 (make-pointer 123)))
|
||
(eq? (wrap-foo p1)
|
||
(wrap-foo p2))))
|
||
|
||
(pass-if "printer"
|
||
(string=? "#<foo! 123>"
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(write (wrap-foo (make-pointer 123))))))))
|
||
|
||
|
||
(with-test-prefix "pointer<->bytevector"
|
||
|
||
(pass-if "bijection"
|
||
(let ((bv #vu8(0 1 2 3 4 5 6 7)))
|
||
(equal? (pointer->bytevector (bytevector->pointer bv)
|
||
(bytevector-length bv))
|
||
bv)))
|
||
|
||
(pass-if "pointer from bits"
|
||
(let* ((bytes (iota (sizeof '*)))
|
||
(bv (u8-list->bytevector bytes))
|
||
(fold (case (native-endianness)
|
||
((little) fold-right)
|
||
((big) fold)
|
||
(else (error "unsupported endianness")))))
|
||
(= (pointer-address
|
||
(make-pointer (bytevector-uint-ref bv 0 (native-endianness)
|
||
(sizeof '*))))
|
||
(fold (lambda (byte address)
|
||
(+ byte (* 256 address)))
|
||
0
|
||
bytes))))
|
||
|
||
(pass-if "dereference-pointer"
|
||
(let* ((bytes (iota (sizeof '*)))
|
||
(bv (u8-list->bytevector bytes))
|
||
(fold (case (native-endianness)
|
||
((little) fold-right)
|
||
((big) fold)
|
||
(else (error "unsupported endianness")))))
|
||
(= (pointer-address
|
||
(dereference-pointer (bytevector->pointer bv)))
|
||
(fold (lambda (byte address)
|
||
(+ byte (* 256 address)))
|
||
0
|
||
bytes)))))
|
||
|
||
|
||
(with-test-prefix "pointer<->string"
|
||
|
||
(pass-if-exception "%default-port-conversion-strategy is error"
|
||
exception:encoding-error
|
||
(let ((s "χαοσ"))
|
||
(with-fluids ((%default-port-conversion-strategy 'error))
|
||
(string->pointer s "ISO-8859-1"))))
|
||
|
||
(pass-if "%default-port-conversion-strategy is escape"
|
||
(let ((s "teĥniko"))
|
||
(equal? (with-fluids ((%default-port-conversion-strategy 'escape))
|
||
(pointer->string (string->pointer s "ISO-8859-1")))
|
||
(format #f "te\\u~4,'0xniko"
|
||
(char->integer #\ĥ)))))
|
||
|
||
(pass-if "%default-port-conversion-strategy is substitute"
|
||
(let ((s "teĥniko")
|
||
(member (negate (negate member))))
|
||
(member (with-fluids ((%default-port-conversion-strategy 'substitute))
|
||
(pointer->string (string->pointer s "ISO-8859-1")))
|
||
'("te?niko"
|
||
|
||
;; This form is found on FreeBSD 8.2 and Darwin 10.8.0.
|
||
"te^hniko"))))
|
||
|
||
(pass-if "bijection"
|
||
(let ((s "hello, world"))
|
||
(string=? s (pointer->string (string->pointer s)))))
|
||
|
||
(pass-if "bijection [latin1]"
|
||
(with-latin1-locale
|
||
(let ((s "Szép jó napot!"))
|
||
(string=? s (pointer->string (string->pointer s))))))
|
||
|
||
(pass-if "bijection, utf-8"
|
||
(let ((s "hello, world"))
|
||
(string=? s (pointer->string (string->pointer s "utf-8")
|
||
-1 "utf-8"))))
|
||
|
||
(pass-if "bijection, utf-8 [latin1]"
|
||
(let ((s "Szép jó napot!"))
|
||
(string=? s (pointer->string (string->pointer s "utf-8")
|
||
-1 "utf-8")))))
|
||
|
||
|
||
|
||
(with-test-prefix "pointer->procedure"
|
||
|
||
(pass-if-exception "object instead of pointer"
|
||
exception:wrong-type-arg
|
||
(let ((p (pointer->procedure '* %null-pointer '(*))))
|
||
(p #t))))
|
||
|
||
|
||
(with-test-prefix "procedure->pointer"
|
||
|
||
(define qsort
|
||
;; Bindings for libc's `qsort' function.
|
||
;; On some platforms, such as MinGW, `qsort' is visible only if
|
||
;; linking with `-export-dynamic'. Just skip these tests when it's
|
||
;; not visible.
|
||
(false-if-exception
|
||
(pointer->procedure void
|
||
(dynamic-func "qsort" (dynamic-link))
|
||
(list '* size_t size_t '*))))
|
||
|
||
(define (dereference-pointer-to-byte ptr)
|
||
(let ((b (pointer->bytevector ptr 1)))
|
||
(bytevector-u8-ref b 0)))
|
||
|
||
(define input
|
||
'(7 1 127 3 5 4 77 2 9 0))
|
||
|
||
(pass-if "qsort"
|
||
(if (and qsort (defined? 'procedure->pointer))
|
||
(let* ((called? #f)
|
||
(cmp (lambda (x y)
|
||
(set! called? #t)
|
||
(- (dereference-pointer-to-byte x)
|
||
(dereference-pointer-to-byte y))))
|
||
(ptr (procedure->pointer int cmp (list '* '*)))
|
||
(bv (u8-list->bytevector input)))
|
||
(qsort (bytevector->pointer bv) (bytevector-length bv) 1
|
||
(procedure->pointer int cmp (list '* '*)))
|
||
(and called?
|
||
(equal? (bytevector->u8-list bv)
|
||
(sort input <))))
|
||
(throw 'unresolved)))
|
||
|
||
(pass-if-exception "qsort, wrong return type"
|
||
exception:wrong-type-arg
|
||
|
||
(if (and qsort (defined? 'procedure->pointer))
|
||
(let* ((cmp (lambda (x y) #f)) ; wrong return type
|
||
(ptr (procedure->pointer int cmp (list '* '*)))
|
||
(bv (u8-list->bytevector input)))
|
||
(qsort (bytevector->pointer bv) (bytevector-length bv) 1
|
||
(procedure->pointer int cmp (list '* '*)))
|
||
#f)
|
||
(throw 'unresolved)))
|
||
|
||
(pass-if-exception "qsort, wrong arity"
|
||
exception:wrong-num-args
|
||
|
||
(if (and qsort (defined? 'procedure->pointer))
|
||
(let* ((cmp (lambda (x y z) #f)) ; wrong arity
|
||
(ptr (procedure->pointer int cmp (list '* '*)))
|
||
(bv (u8-list->bytevector input)))
|
||
(qsort (bytevector->pointer bv) (bytevector-length bv) 1
|
||
(procedure->pointer int cmp (list '* '*)))
|
||
#f)
|
||
(throw 'unresolved)))
|
||
|
||
(pass-if "bijection"
|
||
(if (defined? 'procedure->pointer)
|
||
(let* ((proc (lambda (x y z)
|
||
(+ x y z 0.0)))
|
||
(ret double)
|
||
(args (list float int16 double))
|
||
(proc* (pointer->procedure ret
|
||
(procedure->pointer ret proc args)
|
||
args))
|
||
(arg1 (map (cut / <> 2.0) (iota 123)))
|
||
(arg2 (iota 123 32000))
|
||
(arg3 (map (cut / <> 4.0) (iota 123 100 4))))
|
||
(equal? (map proc arg1 arg2 arg3)
|
||
(map proc* arg1 arg2 arg3)))
|
||
(throw 'unresolved)))
|
||
|
||
(pass-if "procedures returning a pointer"
|
||
(if (defined? 'procedure->pointer)
|
||
(let* ((called? #f)
|
||
(proc (lambda (i) (set! called? #t) (make-pointer i)))
|
||
(pointer (procedure->pointer '* proc (list int)))
|
||
(proc* (pointer->procedure '* pointer (list int)))
|
||
(result (proc* 777)))
|
||
(and called? (equal? result (make-pointer 777))))
|
||
(throw 'unresolved)))
|
||
|
||
(pass-if "procedures returning void"
|
||
(if (defined? 'procedure->pointer)
|
||
(let* ((called? #f)
|
||
(proc (lambda () (set! called? #t)))
|
||
(pointer (procedure->pointer void proc '()))
|
||
(proc* (pointer->procedure void pointer '())))
|
||
(proc*)
|
||
called?)
|
||
(throw 'unresolved)))
|
||
|
||
(pass-if "procedure is retained"
|
||
;; The lambda passed to `procedure->pointer' must remain live.
|
||
(if (defined? 'procedure->pointer)
|
||
(let* ((ptr (procedure->pointer int
|
||
(lambda (x) (+ x 7))
|
||
(list int)))
|
||
(procs (unfold (cut >= <> 10000)
|
||
(lambda (i)
|
||
(pointer->procedure int ptr (list int)))
|
||
1+
|
||
0)))
|
||
(gc) (gc) (gc)
|
||
(every (cut = <> 9)
|
||
(map (lambda (f) (f 2)) procs)))
|
||
(throw 'unresolved)))
|
||
|
||
(pass-if "arity"
|
||
(if (and qsort (defined? 'procedure->pointer))
|
||
(equal? '(4 0 #f) (procedure-minimum-arity qsort))
|
||
(throw 'unresolved))))
|
||
|
||
|
||
(with-test-prefix "structs"
|
||
|
||
(pass-if "sizeof { int8, double }"
|
||
(= (sizeof (list int8 double))
|
||
(+ (alignof double) (sizeof double))))
|
||
|
||
(pass-if "sizeof { double, int8 }"
|
||
(= (sizeof (list double int8))
|
||
(+ (alignof double) (sizeof double))))
|
||
|
||
(pass-if "sizeof { short, int, long, pointer }"
|
||
(let ((layout (list short int long '*)))
|
||
(>= (sizeof layout)
|
||
(reduce + 0.0 (map sizeof layout)))))
|
||
|
||
(pass-if "alignof { int8, double, int8 }"
|
||
;; alignment of the most strictly aligned component
|
||
(let ((layout (list int8 double int8)))
|
||
(= (alignof layout) (alignof double))))
|
||
|
||
(pass-if "parse-c-struct"
|
||
(let ((layout (list int64 uint8))
|
||
(data (list -300 43)))
|
||
(equal? (parse-c-struct (make-c-struct layout data)
|
||
layout)
|
||
data)))
|
||
|
||
(pass-if "alignment constraints honored"
|
||
(let ((layout (list int8 double))
|
||
(data (list -7 3.14)))
|
||
(equal? (parse-c-struct (make-c-struct layout data)
|
||
layout)
|
||
data)))
|
||
|
||
(pass-if "int8, pointer"
|
||
(let ((layout (list uint8 '*))
|
||
(data (list 222 (make-pointer 7777))))
|
||
(equal? (parse-c-struct (make-c-struct layout data)
|
||
layout)
|
||
data)))
|
||
|
||
(pass-if "unsigned-long, int8, size_t"
|
||
(let ((layout (list unsigned-long int8 size_t))
|
||
(data (list (expt 2 17) -128 (expt 2 18))))
|
||
(equal? (parse-c-struct (make-c-struct layout data)
|
||
layout)
|
||
data)))
|
||
|
||
(pass-if "long, int, pointer"
|
||
(let ((layout (list long int '*))
|
||
(data (list (- (expt 2 17)) -222 (make-pointer 777))))
|
||
(equal? (parse-c-struct (make-c-struct layout data)
|
||
layout)
|
||
data)))
|
||
|
||
(pass-if "int8, pointer, short, double"
|
||
(let ((layout (list int8 '* short double))
|
||
(data (list 77 %null-pointer -42 3.14)))
|
||
(equal? (parse-c-struct (make-c-struct layout data)
|
||
layout)
|
||
data)))
|
||
|
||
(pass-if "int8, { int8, double, int8 }, int16"
|
||
(let ((layout (list int8 (list int8 double int8) int16))
|
||
(data (list 77 (list 42 4.2 55) 88)))
|
||
(equal? (parse-c-struct (make-c-struct layout data)
|
||
layout)
|
||
data))))
|