Update of /cvsroot/sbcl/sbcl/contrib/sb-grovel
In directory sc8-pr-cvs1:/tmp/cvs-serv31649/contrib/sb-grovel
Added Files:
Makefile README def-to-lisp.lisp defpackage.lisp
example-constants.lisp foreign-glue.lisp sb-grovel.asd
Log Message:
0.pre8.50
Chopped out unused (largely unimplemented) stream-command mechanism.
Experiemntal "sb-grovel" contrib is a turbo-charged
grovel_headers replacement, which has seen use in
sb-bsd-sockets and is now being made available separately to
see if other packages find it useful too. See sbcl-devel
message "sb-grovel contrib FFI helper code" for more info
--- NEW FILE: Makefile ---
SYSTEM=sb-grovel
include ../asdf-module.mk
--- NEW FILE: README ---
Many of the structure offsets and symbolic constants necessary to do
FFI vary between architectures and operating systems. To avoid a
maintenance nightmare, we derive them automatically by creating and
running a small C program. The C program is created by
def-to-lisp.lisp with input from a GROVEL-CONSTANTS-FILE
The ASDF component type GROVEL-CONSTANTS-FILE has its PERFORM
operation defined to write out a C source file, compile it, and run
it. The output from this program is Lisp, which is then itself
compiled.
How to use it from your own system
1) Create a Lisp package for the foreign constants/functions to go into.
It needs to use SB-GROVEL and SB-ALIEN
2) Make your system depend on the "sb-grovel" system
3) Create a grovel-constants data file - see example-constants.lisp in
this directory
4) Add it as a component in your system. e.g.
(defsystem sbcl-hemlock
:depends-on (sb-grovel)
:components
((:module "sbcl"
:components
((:file "defpackage")
(sb-grovel:grovel-constants-file "example-constants"
:package :sbcl-hemlock
)))))
Make sure to specify the package you chose in step 1
5) Build stuff
---
Note that we assume that the C type char has 8 bits.
--- NEW FILE: def-to-lisp.lisp ---
(in-package :SB-GROVEL)
(defvar *export-symbols* nil)
(defun c-for-structure (stream lisp-name c-struct)
(destructuring-bind (c-name &rest elements) c-struct
(format stream "printf(\"(sb-grovel::define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name)
(dolist (e elements)
(destructuring-bind (lisp-type lisp-el-name c-type c-el-name) e
(format stream "printf(\"(sb-grovel::define-c-accessor ~A-~A ~A ~A \");~%"
lisp-name lisp-el-name lisp-name lisp-type)
;; offset
(format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%"
c-name c-el-name)
;; length
(format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%"
c-name c-el-name)
(format stream "printf(\")\\n\");~%")))))
(defun c-for-function (stream lisp-name alien-defn)
(destructuring-bind (c-name &rest definition) alien-defn
(let ((*print-right-margin* nil))
(format stream "printf(\"(declaim (inline ~A))\\n\");~%"
lisp-name)
(princ "printf(\"(sb-grovel::define-foreign-routine (" stream)
(princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream)
(princ lisp-name stream)
(princ " ) " stream)
(dolist (d definition)
(write d :length nil
:right-margin nil :stream stream)
(princ " " stream))
(format stream ")\\n\");")
(terpri stream))))
(defun print-c-source (stream headers definitions package-name)
(let ((*print-right-margin* nil))
(loop for i in headers
do (format stream "#include <~A>~%" i))
(format stream "main() { ~%
printf(\"(in-package ~S)\\\n\");~%" package-name)
(format stream "printf(\"(deftype int () '(signed-byte %d))\\\n\",8*sizeof (int));~%")
(format stream "printf(\"(deftype char () '(unsigned-byte %d))\\\n\",8*sizeof (char));~%")
(format stream "printf(\"(deftype long () '(unsigned-byte %d))\\\n\",8*sizeof (long));~%")
(dolist (def definitions)
(destructuring-bind (type lispname cname &optional doc) def
(cond ((eq type :integer)
(format stream
"printf(\"(defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%"
lispname doc cname))
((eq type :string)
(format stream
"printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%"
lispname doc cname))
((eq type :function)
(c-for-function stream lispname cname))
((eq type :structure)
(c-for-structure stream lispname cname))
(t
(format stream
"printf(\";; Non hablo Espagnol, Monsieur~%")))))
(format stream "exit(0);~%}")))
(defun c-constants-extract (filename output-file package)
(with-open-file (f output-file :direction :output)
(with-open-file (i filename :direction :input)
(let* ((headers (read i))
(definitions (read i)))
(print-c-source f headers definitions package)))))
(defclass grovel-constants-file (asdf:cl-source-file)
((package :accessor constants-package :initarg :package)))
(defmethod asdf:perform ((op asdf:compile-op)
(component grovel-constants-file))
;; we want to generate all our temporary files in the fasl directory
;; because that's where we have write permission. Can't use /tmp;
;; it's insecure (these files will later be owned by root)
(let* ((output-file (car (output-files op component)))
(filename (component-pathname component))
(real-output-file
(if (typep output-file 'logical-pathname)
(translate-logical-pathname output-file)
(pathname output-file)))
(tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
(tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file))
(tmp-constants (merge-pathnames #p"constants.lisp-temp"
real-output-file)))
(princ (list filename output-file real-output-file
tmp-c-source tmp-a-dot-out tmp-constants))
(terpri)
(funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
filename tmp-c-source (constants-package component))
(and
(= (run-shell-command "gcc -o ~S ~S" (namestring tmp-a-dot-out)
(namestring tmp-c-source)) 0)
(= (run-shell-command "~A >~A"
(namestring tmp-a-dot-out)
(namestring tmp-constants)) 0)
(compile-file tmp-constants :output-file output-file))))
--- NEW FILE: defpackage.lisp ---
(defpackage "SB-GROVEL"
(:export "GROVEL-CONSTANTS-FILE")
(:use "COMMON-LISP" "SB-ALIEN" "ASDF" "SB-EXT"))
--- NEW FILE: example-constants.lisp ---
;;; -*- Lisp -*- - well, that's stretching a point. code=data != data=code
;;; first, the headers necessary to find definitions of everything
("sys/types.h" "sys/socket.h" "sys/stat.h" "unistd.h" "sys/un.h"
"netinet/in.h" "netinet/in_systm.h" "netinet/ip.h" "net/if.h"
"netdb.h" "errno.h" "netinet/tcp.h" "fcntl.h" "signal.h" )
;;; then the stuff we're looking for
((:integer af-inet "AF_INET" "IP Protocol family")
(:integer af-unspec "AF_UNSPEC" "Unspecified.")
(:integer af-local
#+(or sunos solaris) "AF_UNIX"
#-(or sunos solaris) "AF_LOCAL"
"Local to host (pipes and file-domain).")
(:integer sigterm "SIGTERM")
(:structure stat ("struct stat"
(integer dev "dev_t" "st_dev")
(integer atime "time_t" "st_atime")))
(:function accept ("accept" int
(socket int)
(my-addr (* t))
(addrlen int :in-out)))
(:function bind ("bind" int
(sockfd int)
(my-addr (* t))
(addrlen int)))
(:function getpid ("getpid" int ))
(:function getppid ("getppid" int))
(:function kill ("kill" int
(pid int) (signal int)))
(:function mkdir ("mkdir" int
(name c-string))))
--- NEW FILE: foreign-glue.lisp ---
(in-package :sb-grovel)
;;;; The macros defined here are called from #:Gconstants.lisp, which was
;;;; generated from constants.lisp by the C compiler as driven by that
;;;; wacky def-to-lisp thing.
;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
;;; C-CALL:C-STRING) (BUF (* T)) )
;;; I can't help thinking this was originally going to do something a
;;; lot more complex
(defmacro define-foreign-routine
(&whole it (c-name lisp-name) return-type &rest args)
(declare (ignorable c-name lisp-name return-type args))
`(define-alien-routine ,@(cdr it)))
#||
(define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2)
(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2)
||#
;;; define-c-accessor makes us a setter and a getter for changing
;;; memory at the appropriate offset
;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
(defmacro define-c-accessor (el structure type offset length)
(declare (ignore structure))
(let* ((ty (cond
((eql type 'integer) `(,type ,(* 8 length)))
((eql (car type) '*) `(unsigned ,(* 8 length)))
((eql type 'c-string) `(unsigned ,(* 8 length)))
((eql (car type) 'array) (cadr type))))
(sap-ref-? (intern (format nil "~ASAP-REF-~A"
(if (member (car ty) '(INTEGER SIGNED))
"SIGNED-" "")
(cadr ty))
(find-package "SB-SYS"))))
(labels ((template (before after)
`(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr))))
(sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset)))))
(,before (,sap-ref-? sap index) ,after))))
`(progn
;;(declaim (inline ,el (setf ,el)))
(defun ,el (ptr &optional (index 0))
(declare (optimize (speed 3)))
(sb-sys:without-gcing
,(template 'prog1 nil)))
(defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
(defun (setf ,el) (newval ptr &optional (index 0))
(declare (optimize (speed 3)))
(sb-sys:without-gcing
,(template 'setf 'newval)))))))
;;; make memory allocator for appropriately-sized block of memory, and
;;; a constant to tell us how big it was anyway
(defmacro define-c-struct (name size)
(labels ((p (x) (intern (concatenate 'string x (symbol-name name))
(symbol-package name))))
`(progn
(defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
:element-type '(unsigned-byte 8)))
(defconstant ,(p "SIZE-OF-") ,size)
(defun ,(p "FREE-" ) (p) (declare (ignore p))))))
(defun foreign-nullp (c)
"C is a pointer to 0?"
(= 0 (sb-sys:sap-int (sb-alien:alien-sap c))))
;;; this could be a lot faster if I cared enough to think about it
(defun foreign-vector (pointer size length)
"Compose a vector of the words found in foreign memory starting at
POINTER. Each word is SIZE bytes long; LENGTH gives the number of
elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO"
(assert (= size 1))
(let ((ptr
(typecase pointer
(sb-sys:system-area-pointer
(sap-alien pointer (* (sb-alien:unsigned 8))))
(t
(sb-alien:cast pointer (* (sb-alien:unsigned 8))))))
(result (make-array length :element-type '(unsigned-byte 8))))
(loop for i from 0 to (1- length) by size
do (setf (aref result i) (sb-alien:deref ptr i)))
result))
--- NEW FILE: sb-grovel.asd ---
;;; -*- Lisp -*-
(defpackage #:sb-grovel-system (:use #:asdf #:cl))
(in-package #:sb-grovel-system)
(defsystem sb-grovel
:version "0.01"
:components ((:file "defpackage")
(:file "def-to-lisp" :depends-on ("defpackage"))))
(defmethod perform ((o test-op) (c (eql (find-system :sb-grovel))))
t)
|