contrib/sb-grovel/foreign-glue.lisp

   1 (in-package :sb-grovel)
   2
   3 ;;;; The macros defined here are called from #:Gconstants.lisp, which was
   4 ;;;; generated from constants.lisp by the C compiler as driven by that
   5 ;;;; wacky def-to-lisp thing.
   6
   7 ;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
   8 ;;; C-CALL:C-STRING) (BUF (* T)) )
   9
  10 ;;; I can't help thinking this was originally going to do something a
  11 ;;; lot more complex
  12 (defmacro define-foreign-routine
  13   (&whole it (c-name lisp-name) return-type &rest args)
  14   (declare (ignorable c-name lisp-name return-type args))
  15   `(define-alien-routine ,@(cdr it)))
  16
  17
  18
  19 ;;; strctures
  20
  21 #| C structs need: the with-... interface.
  22 |#
  23
  24 ;;; global XXXs:
  25 #|
  26  XXX: :distrust-length t fields are dangerous. they should only be at
  27       the end of the structure (they mess up offset/size calculations)
  28 |#
  29
  30 (defun reintern (symbol &optional (package *package*))
  31   (if (symbolp symbol)
  32       (intern (symbol-name symbol) package)
  33       symbol))
  34
  35 (defparameter alien-type-table (make-hash-table :test 'eql))
  36 (defparameter lisp-type-table (make-hash-table :test 'eql))
  37
  38 (macrolet ((define-alien-types ((type size) &rest defns)
  39                `(progn
  40                   ,@(loop for defn in defns
  41                           collect (destructuring-bind (expected-type c-type lisp-type) defn
  42                                     `(progn
  43                                        (setf (gethash ',expected-type alien-type-table)
  44                                              (lambda (,type ,size)
  45                                                (declare (ignorable type size))
  46                                                ,c-type))
  47                                        (setf (gethash ',expected-type lisp-type-table)
  48                                              (lambda (,type ,size)
  49                                                (declare (ignorable type size))
  50                                                ,lisp-type))))))))
  51   (define-alien-types (type size)
  52       (integer (or (gethash size (symbol-value (intern "*INTEGER-SIZES*")))
  53                    `(integer ,(* 8 size)))
  54                `(unsigned-byte ,(* 8 size)))
  55       (unsigned `(unsigned ,(* 8 size))
  56                 `(unsigned-byte ,(* 8 size)))
  57       (signed `(signed ,(* 8 size))
  58               `(signed-byte ,(* 8 size)))
  59       (c-string `(array char ,size) 'cl:simple-string)
  60       (c-string-pointer 'c-string 'cl:simple-string)
  61       ;; TODO: multi-dimensional arrays, if they are ever needed.
  62       (array (destructuring-bind (array-tag elt-type &optional array-size) type
  63                (declare (ignore array-tag))
  64                ;; XXX: use of EVAL.  alien-size is a macro,
  65                ;; unfortunately; and it will only accept unquoted type
  66                ;; forms.
  67                `(sb-alien:array ,elt-type ,(or array-size
  68                                   (/ size (eval `(sb-alien:alien-size ,elt-type :bytes))))))
  69              `(vector t))))
  70
  71 (defun retrieve-type-for (type size table)
  72   (multiple-value-bind (type-fn found)
  73       (gethash (reintern (typecase type
  74                            (list (first type))
  75                            (t    type))
  76                          (find-package '#:sb-grovel))
  77                table)
  78     (values
  79      (if found
  80          (funcall (the function type-fn) type size)
  81          type)
  82      found)))
  83
  84 (defun alien-type-for (type size)
  85   (reintern (retrieve-type-for type size alien-type-table)))
  86
  87 (defun lisp-type-for (type size)
  88   (multiple-value-bind (val found)
  89       (retrieve-type-for type size lisp-type-table)
  90     (if found
  91         val
  92         t)))
  93
  94
  95 (defun mk-padding (len offset)
  96   (make-instance 'padding
  97                  :type `(array char ,len)
  98                  :offset offset
  99                  :size len
 100                  :name (gensym "PADDING")))
 101 (defun mk-struct (offset &rest children)
 102   (make-instance 'struct :name (gensym "STRUCT")
 103                  :children (remove nil children)
 104                  :offset offset))
 105 (defun mk-union (offset &rest children)
 106   (make-instance 'union :name (gensym "UNION")
 107                  :children (remove nil children)
 108                  :offset offset))
 109 (defun mk-val (name type h-type offset size)
 110   (declare (ignore h-type))
 111   (make-instance 'value-slot :name name
 112                  :size size
 113                  :offset offset
 114                  :type type))
 115
 116 ;;; struct tree classes
 117
 118 (defclass slot ()
 119   ((offset :initarg :offset :reader offset)
 120    (name :initarg :name :reader name)))
 121
 122 (defclass structured-type (slot)
 123   ((children :initarg :children :accessor children)))
 124
 125 (defclass union (structured-type)
 126   ())
 127
 128 (defclass struct (structured-type)
 129   ())
 130
 131 (defclass value-slot (slot)
 132   ((size :initarg :size :reader size)
 133    (type :initarg :type :reader type)))
 134
 135 (defclass padding (value-slot)
 136   ())
 137
 138 (defmethod print-object ((o value-slot) s)
 139   (print-unreadable-object (o s :type t)
 140     (format s "~S ~A+~A=~A" (name o) (offset o) (size o) (slot-end o))))
 141
 142 (defmethod print-object ((o structured-type) s)
 143   (print-unreadable-object (o s :type t)
 144     (format s "~S ~A" (name o) (children o))))
 145
 146 (defmethod size ((slot structured-type))
 147   (let ((min-offset (offset slot)))
 148     (if (null (children slot))
 149         0
 150         (reduce #'max (mapcar (lambda (child)
 151                                 (+ (- (offset child) min-offset) (size child)))
 152                               (children slot))
 153                 :initial-value 0))))
 154
 155 (defgeneric slot-end (slot))
 156 (defmethod slot-end ((slot slot))
 157   (+ (offset slot) (size slot)))
 158
 159 (defun overlap-p (elt1 elt2)
 160   (unless (or (zerop (size elt1))
 161               (zerop (size elt2)))
 162     (or
 163      (and (<= (offset elt1)
 164               (offset elt2))
 165           (< (offset elt2)
 166              (slot-end elt1)))
 167      (and (<= (offset elt2)
 168               (offset elt1))
 169           (< (offset elt1)
 170              (slot-end elt2))))))
 171
 172 (defgeneric find-overlaps (root new-element))
 173 (defmethod find-overlaps ((root structured-type) new-element)
 174   (when (overlap-p root new-element)
 175     (let ((overlapping-elts (loop for child in (children root)
 176                                   for overlap = (find-overlaps child new-element)
 177                                   when overlap
 178                                      return overlap)))
 179       (cons root overlapping-elts))))
 180
 181 (defmethod find-overlaps ((root value-slot) new-element)
 182   (when (overlap-p root new-element)
 183     (list root)))
 184
 185 (defgeneric pad-to-offset-of (to-pad parent))
 186   (macrolet ((skel (end-form)
 187              `(let* ((end ,end-form)
 188                      (len (abs (- (offset to-pad) end))))
 189                 (cond
 190                   ((= end (offset to-pad)) ; we are at the right offset.
 191                    nil)
 192                   (t                    ; we have to pad between the
 193                                         ; old slot's end and the new
 194                                         ; slot's offset
 195                    (mk-padding len end))))))
 196
 197   (defmethod pad-to-offset-of (to-pad (parent struct))
 198     (skel (if (null (children parent))
 199               0
 200               (+ (size parent) (offset parent)))))
 201   (defmethod pad-to-offset-of (to-pad (parent union))
 202     (skel (if (null (children parent))
 203               (offset to-pad)
 204               (offset parent)))))
 205
 206 (defgeneric replace-by-union (in-st element new-element))
 207 (defmethod replace-by-union ((in-st struct) elt new-elt)
 208   (setf (children in-st) (remove elt (children in-st)))
 209   (let ((padding (pad-to-offset-of new-elt in-st)))
 210     (setf (children in-st)
 211           (nconc (children in-st)
 212                  (list (mk-union (offset elt)
 213                                  elt
 214                                  (if padding
 215                                      (mk-struct (offset elt)
 216                                                 padding
 217                                                 new-elt)
 218                                      new-elt)))))))
 219
 220 (defmethod replace-by-union ((in-st union) elt new-elt)
 221   (let ((padding (pad-to-offset-of new-elt in-st)))
 222     (setf (children in-st)
 223           (nconc (children in-st)
 224                  (list (if padding
 225                            (mk-struct (offset in-st)
 226                                       padding
 227                                       new-elt)
 228                            new-elt))))))
 229
 230 (defgeneric insert-element (root new-elt))
 231 (defmethod insert-element ((root struct) (new-elt slot))
 232   (let ((overlaps (find-overlaps root new-elt)))
 233     (cond
 234       (overlaps (let ((last-structure (first (last overlaps 2)))
 235                       (last-val (first (last overlaps))))
 236                   (replace-by-union last-structure last-val new-elt)
 237                   root))
 238       (t
 239        (let ((padding (pad-to-offset-of new-elt root)))
 240          (setf (children root)
 241                (nconc (children root)
 242                       (when padding (list padding))
 243                       (list new-elt)))))))
 244   root)
 245
 246 (defun sane-slot (alien-var &rest slots)
 247   "Emulates the SB-ALIEN:SLOT interface, with useful argument order for
 248 deeply nested structures."
 249   (labels ((rewriter (slots)
 250              (if (null slots)
 251                  alien-var
 252                  `(sb-alien:slot ,(rewriter (rest slots))
 253                                  ',(first slots)))))
 254     (rewriter slots)))
 255
 256 (defgeneric accessor-modifier-for (element-type accessor-type))
 257
 258 (defun identity-1 (thing &rest ignored)
 259   (declare (ignore ignored))
 260   thing)
 261 (defun (setf identity-1) (new-thing place &rest ignored)
 262   (declare (ignore ignored))
 263   (setf place new-thing))
 264
 265 (defmethod accessor-modifier-for (element-type (accessor-type (eql :getter)))
 266   'identity-1)
 267 (defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
 268                                   (accessor-type (eql :getter)))
 269   'c-string->lisp-string)
 270 (defmethod accessor-modifier-for (element-type (accessor-type (eql :setter)))
 271   nil)
 272 (defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
 273                                   (accessor-type (eql :setter)))
 274   'c-string->lisp-string)
 275 (defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
 276                                   (accessor-type (eql :getter)))
 277   'c-string->lisp-string)
 278
 279 (defun c-string->lisp-string (string &optional limit)
 280   (declare (ignore limit))
 281   (cast string c-string))
 282
 283 (defun (setf c-string->lisp-string) (new-string alien &optional limit)
 284   (declare (string new-string))
 285   (let* ((upper-bound (or limit (1+ (length new-string))))
 286          (last-elt (min (1- upper-bound) (length new-string))))
 287     (loop for i upfrom 0 below last-elt
 288           for char across new-string
 289           do (setf (deref alien i) (char-code char)))
 290     (setf (deref alien last-elt) 0)
 291     (subseq new-string 0 last-elt)))
 292
 293 (defgeneric accessors-for (struct-name element path))
 294 (defmethod accessors-for (struct-name (root structured-type) path)
 295   nil)
 296
 297
 298 (defmethod accessors-for (struct-name (root value-slot) path)
 299   (let ((rpath (reverse path))
 300         (accessor-name (format nil "~A-~A"
 301                                (symbol-name struct-name)
 302                                (symbol-name (name root)))))
 303     (labels ((accessor (root rpath)
 304                (apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root))))))
 305       `((defun ,(intern accessor-name) (struct)
 306           (declare (cl:type (alien ,struct-name) struct)
 307                    (optimize (speed 3)))
 308           (,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel))
 309                                    :getter)
 310             ,(accessor root rpath) ,(size root)))
 311         (defun (setf ,(intern accessor-name)) (new-val struct)
 312           (declare (cl:type (alien ,struct-name) struct)
 313                    (cl:type ,(lisp-type-for (type root) (size root)) new-val)
 314                    (optimize (speed 3)))
 315           ,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root)
 316                                                                       (find-package :sb-grovel))
 317                                                             :setter))
 318                   (modified-accessor (if accessor-modifier
 319                                          `(,accessor-modifier ,(accessor root rpath) ,(size root))
 320                                          (accessor root rpath))))
 321
 322              `(setf ,modified-accessor new-val)))
 323         (defconstant ,(intern (format nil "OFFSET-OF-~A" accessor-name))
 324           ,(offset root))))))
 325
 326
 327
 328 (defmethod accessors-for (struct (root padding) path)
 329   nil)
 330
 331 (defgeneric generate-struct-definition (struct-name root path))
 332 (defmethod generate-struct-definition (struct-name (root structured-type) path)
 333   (let ((naccessors (accessors-for struct-name root path))
 334         (nslots nil))
 335     (dolist (child (children root))
 336       (multiple-value-bind (slots accessors)
 337           (generate-struct-definition struct-name child (cons root path))
 338         (setf nslots (nconc nslots slots))
 339         (setf naccessors (nconc naccessors accessors))))
 340     (values `((,(name root) (,(type-of root) ,(name root) ,@nslots)))
 341             naccessors)))
 342
 343 (defmethod generate-struct-definition (struct-name (root value-slot) path)
 344   (values `((,(name root) ,(alien-type-for (type root) (size root))))
 345           (accessors-for struct-name root path)))
 346
 347 (defmacro define-c-struct (name size &rest elements)
 348   (multiple-value-bind (struct-elements accessors)
 349       (let* ((root (make-instance 'struct :name name :children nil :offset 0)))
 350         (loop for e in (sort elements #'< :key #'fourth)
 351               do (insert-element root (apply 'mk-val e))
 352               finally (return root))
 353         (setf (children root)
 354               (nconc (children root)
 355                      (list
 356                       (mk-padding (max 0 (- size
 357                                             (size root)))
 358                                   (size root)))))
 359         (generate-struct-definition name root nil))
 360     `(progn
 361        (eval-when (:compile-toplevel :load-toplevel :execute)
 362          (sb-alien:define-alien-type ,@(first struct-elements)))
 363        ,@accessors
 364        (defmacro ,(intern (format nil "WITH-~A" name)) (var (&rest field-values) &body body)
 365          (labels ((field-name (x)
 366                     (intern (concatenate 'string
 367                                          (symbol-name ',name) "-"
 368                                          (symbol-name x))
 369                             ,(symbol-package name))))
 370            `(let ((,var ,'(,(intern (format nil "ALLOCATE-~A" name)))))
 371               (unwind-protect
 372                   (progn
 373                     (progn ,@(mapcar (lambda (pair)
 374                                        `(setf (,(field-name (first pair)) ,var) ,(second pair)))
 375                                      field-values))
 376                     ,@body)
 377                 (funcall ',',(intern (format nil "FREE-~A" name)) ,var)))))
 378        (defconstant ,(intern (format nil "SIZE-OF-~A" name)) ,size)
 379        (defun ,(intern (format nil "ALLOCATE-~A" name)) ()
 380          (let* ((o (sb-alien:make-alien ,name))
 381                 (c-o (cast o (* (unsigned 8)))))
 382            ;; we have to initialize the object to all-0 before we can
 383            ;; expect to make sensible use of it - the object returned
 384            ;; by make-alien is initialized to all-D0 bytes.
 385
 386            ;; FIXME: This should be fixed in sb-alien, where better
 387            ;; optimizations might be possible.
 388            (loop for i from 0 below ,size
 389                  do (setf (deref c-o i) 0))
 390            o))
 391        (defun ,(intern (format nil "FREE-~A" name)) (o)
 392          (sb-alien:free-alien o)))))
 393
 394 (defun foreign-nullp (c)
 395   "C is a pointer to 0?"
 396   (null-alien c))