src/code/early-alieneval.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!ALIEN")
  11
  12 (defglobal *alien-type-classes* (make-hash-table :test 'eq))
  13
  14 (defvar *new-auxiliary-types* nil)
  15
  16 ;;; the list of record types that have already been unparsed. This is
  17 ;;; used to keep from outputting the slots again if the same structure
  18 ;;; shows up twice.
  19 (defvar *record-types-already-unparsed*)
  20
  21 ;;; not documented in CMU CL:-(
  22 ;;;
  23 ;;; reverse engineering observations:
  24 ;;;   * seems to be set when translating return values
  25 ;;;   * seems to enable the translation of (VALUES), which is the
  26 ;;;     Lisp idiom for C's return type "void" (which is likely
  27 ;;;     why it's set when when translating return values)
  28 (defvar *values-type-okay* nil)
  29
  30 (defvar *default-c-string-external-format* nil)
  31
  32 (defmacro define-alien-type-translator (name lambda-list &body body)
  33   (let ((defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")))
  34     `(eval-when (:compile-toplevel :load-toplevel :execute)
  35        (setf (symbol-function ',defun-name)
  36              ,(make-macro-lambda defun-name lambda-list body
  37                                  'define-alien-type-translator name))
  38        (%define-alien-type-translator ',name #',defun-name))))
  39
  40 ;;; Process stuff in a new scope.
  41 (defmacro with-auxiliary-alien-types (env &body body)
  42   ``(symbol-macrolet ((&auxiliary-type-definitions&
  43                        ,(append *new-auxiliary-types*
  44                                 (auxiliary-type-definitions ,env))))
  45       ,(let ((*new-auxiliary-types* nil))
  46          ,@body)))
  47
  48 (defmacro define-alien-type (name type &environment env)
  49   "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for
  50    STRUCT and UNION types, in which case the name is taken from the type
  51    specifier."
  52   (with-auxiliary-alien-types env
  53     (let ((alien-type (parse-alien-type type env)))
  54       `(eval-when (:compile-toplevel :load-toplevel :execute)
  55          ,@(when *new-auxiliary-types*
  56              `((%def-auxiliary-alien-types ',*new-auxiliary-types*
  57                                            (sb!c:source-location))))
  58          ,@(when name
  59              `((%define-alien-type ',name ',alien-type (sb!c:source-location))))))))
  60
  61 (defstruct (alien-type-class (:copier nil))
  62   (name nil :type symbol)
  63   (defstruct-name nil :type symbol)
  64   (include nil :type (or null alien-type-class))
  65   (unparse nil :type (or null function))
  66   (type= nil :type (or null function))
  67   (lisp-rep nil :type (or null function))
  68   (alien-rep nil :type (or null function))
  69   (extract-gen nil :type (or null function))
  70   (deposit-gen nil :type (or null function))
  71   (naturalize-gen nil :type (or null function))
  72   (deport-gen nil :type (or null function))
  73   (deport-alloc-gen nil :type (or null function))
  74   (deport-pin-p nil :type (or null function))
  75   ;; Cast?
  76   (arg-tn nil :type (or null function))
  77   (result-tn nil :type (or null function))
  78   (subtypep nil :type (or null function)))
  79
  80 (defmethod print-object ((type-class alien-type-class) stream)
  81   (print-unreadable-object (type-class stream :type t)
  82     (prin1 (alien-type-class-name type-class) stream)))
  83
  84 (defun alien-type-class-or-lose (name)
  85   (or (gethash name *alien-type-classes*)
  86       (error "no alien type class ~S" name)))
  87
  88 (defun create-alien-type-class-if-necessary (name defstruct-name include)
  89   (let ((old (gethash name *alien-type-classes*))
  90         (include (and include (alien-type-class-or-lose include))))
  91     (if old
  92         (setf (alien-type-class-include old) include)
  93         (setf (gethash name *alien-type-classes*)
  94               (make-alien-type-class :name name
  95                                      :defstruct-name defstruct-name
  96                                      :include include)))))
  97
  98 (defconstant-eqx +method-slot-alist+
  99   '((:unparse . alien-type-class-unparse)
 100     (:type= . alien-type-class-type=)
 101     (:subtypep . alien-type-class-subtypep)
 102     (:lisp-rep . alien-type-class-lisp-rep)
 103     (:alien-rep . alien-type-class-alien-rep)
 104     (:extract-gen . alien-type-class-extract-gen)
 105     (:deposit-gen . alien-type-class-deposit-gen)
 106     (:naturalize-gen . alien-type-class-naturalize-gen)
 107     (:deport-gen . alien-type-class-deport-gen)
 108     (:deport-alloc-gen . alien-type-class-deport-alloc-gen)
 109     (:deport-pin-p . alien-type-class-deport-pin-p)
 110     ;; cast?
 111     (:arg-tn . alien-type-class-arg-tn)
 112     (:result-tn . alien-type-class-result-tn))
 113   #'equal)
 114
 115 (defun method-slot (method)
 116   (cdr (or (assoc method +method-slot-alist+)
 117            (error "no method ~S" method))))
 118
 119 (defmacro invoke-alien-type-method (method type &rest args)
 120   (let ((slot (method-slot method)))
 121     (once-only ((type type))
 122       `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type))
 123                             (alien-type-class-include class)))
 124                     ((null class)
 125                      (error "method ~S not defined for ~S"
 126                             ',method (alien-type-class ,type)))
 127                   (let ((fn (,slot class)))
 128                     (when fn
 129                       (return fn))))
 130                 ,type ,@args))))
 131
 132 #+sb-xc
 133 (defmacro maybe-with-pinned-objects (variables types &body body)
 134   (declare (ignorable variables types))
 135   (let ((pin-variables
 136          ;; Only pin things on GENCGC, since on CHENEYGC it'd imply
 137          ;; disabling the GC.  Which is something we don't want to do
 138          ;; every time we're calling to C.
 139          #!+gencgc
 140          (loop for variable in variables
 141             for type in types
 142             when (invoke-alien-type-method :deport-pin-p type)
 143             collect variable)))
 144     (if pin-variables
 145         `(with-pinned-objects ,pin-variables
 146            ,@body)
 147         `(progn
 148            ,@body))))