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 (defvar *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   #!+sb-doc
  50   "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for
  51    STRUCT and UNION types, in which case the name is taken from the type
  52    specifier."
  53   (with-auxiliary-alien-types env
  54     (let ((alien-type (parse-alien-type type env)))
  55       `(eval-when (:compile-toplevel :load-toplevel :execute)
  56          ,@(when *new-auxiliary-types*
  57              `((%def-auxiliary-alien-types ',*new-auxiliary-types*
  58                                            (sb!c:source-location))))
  59          ,@(when name
  60              `((%define-alien-type ',name ',alien-type)
  61                (setf (info :source-location :alien-type ',name)
  62                      (sb!c:source-location))))))))
  63
  64 (defstruct (alien-type-class (:copier nil))
  65   (name nil :type symbol)
  66   (defstruct-name nil :type symbol)
  67   (include nil :type (or null alien-type-class))
  68   (unparse nil :type (or null function))
  69   (type= nil :type (or null function))
  70   (lisp-rep nil :type (or null function))
  71   (alien-rep nil :type (or null function))
  72   (extract-gen nil :type (or null function))
  73   (deposit-gen nil :type (or null function))
  74   (naturalize-gen nil :type (or null function))
  75   (deport-gen nil :type (or null function))
  76   (deport-alloc-gen nil :type (or null function))
  77   (deport-pin-p nil :type (or null function))
  78   ;; Cast?
  79   (arg-tn nil :type (or null function))
  80   (result-tn nil :type (or null function))
  81   (subtypep nil :type (or null function)))
  82
  83 (defmethod print-object ((type-class alien-type-class) stream)
  84   (print-unreadable-object (type-class stream :type t)
  85     (prin1 (alien-type-class-name type-class) stream)))
  86
  87 (defun alien-type-class-or-lose (name)
  88   (or (gethash name *alien-type-classes*)
  89       (error "no alien type class ~S" name)))
  90
  91 (defun create-alien-type-class-if-necessary (name defstruct-name include)
  92   (let ((old (gethash name *alien-type-classes*))
  93         (include (and include (alien-type-class-or-lose include))))
  94     (if old
  95         (setf (alien-type-class-include old) include)
  96         (setf (gethash name *alien-type-classes*)
  97               (make-alien-type-class :name name
  98                                      :defstruct-name defstruct-name
  99                                      :include include)))))
 100
 101 (defconstant-eqx +method-slot-alist+
 102   '((:unparse . alien-type-class-unparse)
 103     (:type= . alien-type-class-type=)
 104     (:subtypep . alien-type-class-subtypep)
 105     (:lisp-rep . alien-type-class-lisp-rep)
 106     (:alien-rep . alien-type-class-alien-rep)
 107     (:extract-gen . alien-type-class-extract-gen)
 108     (:deposit-gen . alien-type-class-deposit-gen)
 109     (:naturalize-gen . alien-type-class-naturalize-gen)
 110     (:deport-gen . alien-type-class-deport-gen)
 111     (:deport-alloc-gen . alien-type-class-deport-alloc-gen)
 112     (:deport-pin-p . alien-type-class-deport-pin-p)
 113     ;; cast?
 114     (:arg-tn . alien-type-class-arg-tn)
 115     (:result-tn . alien-type-class-result-tn))
 116   #'equal)
 117
 118 (defun method-slot (method)
 119   (cdr (or (assoc method +method-slot-alist+)
 120            (error "no method ~S" method))))
 121
 122 (defmacro invoke-alien-type-method (method type &rest args)
 123   (let ((slot (method-slot method)))
 124     (once-only ((type type))
 125       `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type))
 126                             (alien-type-class-include class)))
 127                     ((null class)
 128                      (error "method ~S not defined for ~S"
 129                             ',method (alien-type-class ,type)))
 130                   (let ((fn (,slot class)))
 131                     (when fn
 132                       (return fn))))
 133                 ,type ,@args))))
 134
 135 #+sb-xc
 136 (defmacro maybe-with-pinned-objects (variables types &body body)
 137   (declare (ignorable variables types))
 138   (let ((pin-variables
 139          ;; Only pin things on GENCGC, since on CHENEYGC it'd imply
 140          ;; disabling the GC.  Which is something we don't want to do
 141          ;; every time we're calling to C.
 142          #!+gencgc
 143          (loop for variable in variables
 144             for type in types
 145             when (invoke-alien-type-method :deport-pin-p type)
 146             collect variable)))
 147     (if pin-variables
 148         `(with-pinned-objects ,pin-variables
 149            ,@body)
 150         `(progn
 151            ,@body))))