src/code/host-alieneval.lisp

   1 ;;;; the part of the Alien implementation which is needed at
   2 ;;;; cross-compilation time
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!ALIEN")
  14
  15 (/show0 "host-alieneval.lisp 15")
  16 \f
  17 ;;;; utility functions
  18
  19 (defun align-offset (offset alignment)
  20   (let ((extra (rem offset alignment)))
  21     (if (zerop extra) offset (+ offset (- alignment extra)))))
  22
  23 (defun guess-alignment (bits)
  24   (cond ((null bits) nil)
  25         #!-(or (and x86 (not win32)) (and ppc darwin)) ((> bits 32) 64)
  26         ((> bits 16) 32)
  27         ((> bits 8) 16)
  28         ((> bits 1) 8)
  29         (t 1)))
  30 \f
  31 ;;;; ALIEN-TYPE-INFO stuff
  32
  33 ;;; We define a keyword "BOA" constructor so that we can reference the
  34 ;;; slot names in init forms.
  35 (defmacro define-alien-type-class ((name &key include include-args) &rest slots)
  36   (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
  37     (multiple-value-bind (include include-defstruct overrides)
  38         (etypecase include
  39           (null
  40            (values nil 'alien-type nil))
  41           (symbol
  42            (values
  43             include
  44             (alien-type-class-defstruct-name
  45              (alien-type-class-or-lose include))
  46             nil))
  47           (list
  48            (values
  49             (car include)
  50             (alien-type-class-defstruct-name
  51              (alien-type-class-or-lose (car include)))
  52             (cdr include))))
  53       `(progn
  54          (eval-when (:compile-toplevel :load-toplevel :execute)
  55            (create-alien-type-class-if-necessary ',name ',defstruct-name
  56                                                  ',(or include 'root)))
  57          (def!struct (,defstruct-name
  58                         (:include ,include-defstruct
  59                                   (class ',name)
  60                                   ,@overrides)
  61                         (:constructor
  62                          ,(symbolicate "MAKE-" defstruct-name)
  63                          (&key class bits alignment
  64                                ,@(mapcar (lambda (x)
  65                                            (if (atom x) x (car x)))
  66                                          slots)
  67                                ,@include-args
  68                                ;; KLUDGE
  69                                &aux (alignment (or alignment (guess-alignment bits))))))
  70            ,@slots)))))
  71
  72 (defmacro define-alien-type-method ((class method) lambda-list &rest body)
  73   (let ((defun-name (symbolicate class "-" method "-METHOD")))
  74     `(progn
  75        (defun ,defun-name ,lambda-list
  76          ,@body)
  77        (setf (,(method-slot method) (alien-type-class-or-lose ',class))
  78              #',defun-name))))
  79 \f
  80 ;;;; type parsing and unparsing
  81
  82 ;;; CMU CL used COMPILER-LET to bind *AUXILIARY-TYPE-DEFINITIONS*, and
  83 ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
  84 ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
  85 ;;; a similar effect.
  86 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  87   (defun auxiliary-type-definitions (env)
  88     (multiple-value-bind (result expanded-p)
  89         (%macroexpand '&auxiliary-type-definitions& env)
  90       (if expanded-p
  91           result
  92           ;; This is like having the global symbol-macro definition be
  93           ;; NIL, but global symbol-macros make me vaguely queasy, so
  94           ;; I do it this way instead.
  95           nil))))
  96
  97 ;;; Parse TYPE as an alien type specifier and return the resultant
  98 ;;; ALIEN-TYPE structure.
  99 (defun parse-alien-type (type env)
 100   (declare (type sb!kernel:lexenv-designator env))
 101   (if (consp type)
 102       (let ((translator (info :alien-type :translator (car type))))
 103         (unless translator
 104           (error "unknown alien type: ~S" type))
 105         (funcall translator type env))
 106       (ecase (info :alien-type :kind type)
 107         (:primitive
 108          (let ((translator (info :alien-type :translator type)))
 109            (unless translator
 110              (error "no translator for primitive alien type ~S" type))
 111            (funcall translator (list type) env)))
 112         (:defined
 113          (or (info :alien-type :definition type)
 114              (error "no definition for alien type ~S" type)))
 115         (:unknown
 116          (error "unknown alien type: ~S" type)))))
 117
 118 (defun auxiliary-alien-type (kind name env)
 119   (declare (type sb!kernel:lexenv-designator env))
 120   (flet ((aux-defn-matches (x)
 121            (and (eq (first x) kind) (eq (second x) name))))
 122     (let ((in-auxiliaries
 123            (or (find-if #'aux-defn-matches *new-auxiliary-types*)
 124                (find-if #'aux-defn-matches (auxiliary-type-definitions env)))))
 125       (if in-auxiliaries
 126           (values (third in-auxiliaries) t)
 127           (info :alien-type kind name)))))
 128
 129 (defun (setf auxiliary-alien-type) (new-value kind name env)
 130   (declare (type sb!kernel:lexenv-designator env))
 131   (flet ((aux-defn-matches (x)
 132            (and (eq (first x) kind) (eq (second x) name))))
 133     (when (find-if #'aux-defn-matches *new-auxiliary-types*)
 134       (error "attempt to multiply define ~A ~S" kind name))
 135     (when (find-if #'aux-defn-matches (auxiliary-type-definitions env))
 136       (error "attempt to shadow definition of ~A ~S" kind name)))
 137   (push (list kind name new-value) *new-auxiliary-types*)
 138   new-value)
 139
 140 (defun verify-local-auxiliaries-okay ()
 141   (dolist (info *new-auxiliary-types*)
 142     (destructuring-bind (kind name defn) info
 143       (declare (ignore defn))
 144       (when (info :alien-type kind name)
 145         (error "attempt to shadow definition of ~A ~S" kind name)))))
 146
 147 (defun unparse-alien-type (type)
 148   #!+sb-doc
 149   "Convert the alien-type structure TYPE back into a list specification of
 150    the type."
 151   (declare (type alien-type type))
 152   (let ((*record-types-already-unparsed* nil))
 153     (%unparse-alien-type type)))
 154
 155 ;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we
 156 ;;; need to recurse inside the binding of
 157 ;;; *RECORD-TYPES-ALREADY-UNPARSED*.
 158 (defun %unparse-alien-type (type)
 159   (invoke-alien-type-method :unparse type))
 160 \f
 161 ;;;; alien type defining stuff
 162
 163 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 164   (defun %define-alien-type-translator (name translator)
 165     (setf (info :alien-type :kind name) :primitive)
 166     (setf (info :alien-type :translator name) translator)
 167     (clear-info :alien-type :definition name)
 168     name))
 169
 170 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 171   (defun %def-auxiliary-alien-types (types source-location)
 172     (dolist (info types)
 173       ;; Clear up the type we're about to define from the toplevel
 174       ;; *new-auxiliary-types* (local scopes take care of themselves).
 175       ;; Unless this is done we never actually get back the full type
 176       ;; from INFO, since the *new-auxiliary-types* have precendence.
 177       (setf *new-auxiliary-types*
 178             (remove info *new-auxiliary-types*
 179                     :test (lambda (a b)
 180                             (and (eq (first a) (first b))
 181                                  (eq (second a) (second b))))))
 182       (destructuring-bind (kind name defn) info
 183         (let ((old (info :alien-type kind name)))
 184           (unless (or (null old) (alien-type-= old defn))
 185             (warn "redefining ~A ~S to be:~%  ~S,~%was:~%  ~S"
 186                   kind name defn old)))
 187         (setf (info :alien-type kind name) defn
 188               (info :source-location :alien-type name) source-location))))
 189
 190   (defun %define-alien-type (name new)
 191     (ecase (info :alien-type :kind name)
 192       (:primitive
 193        (error "~S is a built-in alien type." name))
 194       (:defined
 195        (let ((old (info :alien-type :definition name)))
 196          (unless (or (null old) (alien-type-= new old))
 197            (warn "redefining ~S to be:~%  ~S,~%was~%  ~S"
 198                  name
 199                  (unparse-alien-type new)
 200                  (unparse-alien-type old)))))
 201       (:unknown))
 202     (setf (info :alien-type :definition name) new)
 203     (setf (info :alien-type :kind name) :defined)
 204     name))
 205 \f
 206 ;;;; the root alien type
 207
 208 (eval-when (:compile-toplevel :load-toplevel :execute)
 209   (create-alien-type-class-if-necessary 'root 'alien-type nil))
 210
 211 (def!method print-object ((type alien-type) stream)
 212   (print-unreadable-object (type stream :type t)
 213     ;; Kludge to avoid printing #'(SIGNED 64) instead of (FUNCTION (SIGNED 64))
 214     ;; for a 0-argument function. This is only a problem with alien types
 215     ;; because ordinary FUNCTION type specifiers are 3-lists.
 216     (let ((sb!pretty:*pprint-quote-with-syntactic-sugar* nil))
 217       ;; forward-reference of this special variable unfortunately
 218       (declare (special sb!pretty:*pprint-quote-with-syntactic-sugar*))
 219       (prin1 (unparse-alien-type type) stream))))
 220 \f
 221 ;;;; the SAP type
 222
 223 (define-alien-type-class (system-area-pointer))
 224
 225 (define-alien-type-translator system-area-pointer ()
 226   (make-alien-system-area-pointer-type
 227    :bits sb!vm:n-machine-word-bits))
 228
 229 (define-alien-type-method (system-area-pointer :unparse) (type)
 230   (declare (ignore type))
 231   'system-area-pointer)
 232
 233 (define-alien-type-method (system-area-pointer :lisp-rep) (type)
 234   (declare (ignore type))
 235   'system-area-pointer)
 236
 237 (define-alien-type-method (system-area-pointer :alien-rep) (type context)
 238   (declare (ignore type context))
 239   'system-area-pointer)
 240
 241 (define-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
 242   (declare (ignore type))
 243   alien)
 244
 245 (define-alien-type-method (system-area-pointer :deport-gen) (type object)
 246   (declare (ignore type))
 247   (/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object)
 248   object)
 249
 250 (define-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
 251   (declare (ignore type))
 252   `(sap-ref-sap ,sap (/ ,offset sb!vm:n-byte-bits)))
 253 \f
 254 ;;;; the ALIEN-VALUE type
 255
 256 (define-alien-type-class (alien-value :include system-area-pointer))
 257
 258 (define-alien-type-method (alien-value :lisp-rep) (type)
 259   (declare (ignore type))
 260   nil)
 261
 262 (define-alien-type-method (alien-value :naturalize-gen) (type alien)
 263   `(%sap-alien ,alien ',type))
 264
 265 (define-alien-type-method (alien-value :deport-gen) (type value)
 266   (declare (ignore type))
 267   (/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value)
 268   `(alien-sap ,value))
 269 \f
 270 ;;; HEAP-ALIEN-INFO -- defstruct.
 271 ;;;
 272 (def!method print-object ((info heap-alien-info) stream)
 273   (print-unreadable-object (info stream :type t)
 274     (funcall (formatter "~S ~S~@[ (data)~]")
 275              stream
 276              (heap-alien-info-alien-name info)
 277              (unparse-alien-type (heap-alien-info-type info))
 278              (heap-alien-info-datap info))))
 279
 280 ;;; The form to evaluate to produce the SAP pointing to where in the heap
 281 ;;; it is.
 282 (defun heap-alien-info-sap-form (info)
 283   `(foreign-symbol-sap ,(heap-alien-info-alien-name info)
 284                        ,(heap-alien-info-datap info)))
 285
 286 #-sb-xc-host ; No FOREIGN-SYMBOL-SAP
 287 (defun heap-alien-info-sap (info)
 288   (foreign-symbol-sap (heap-alien-info-alien-name info)
 289                       (heap-alien-info-datap info)))
 290 \f
 291 ;;;; Interfaces to the different methods
 292
 293 (defun alien-type-= (type1 type2)
 294   #!+sb-doc
 295   "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
 296   (or (eq type1 type2)
 297       (and (eq (alien-type-class type1)
 298                (alien-type-class type2))
 299            (invoke-alien-type-method :type= type1 type2))))
 300
 301 (defun alien-subtype-p (type1 type2)
 302   #!+sb-doc
 303   "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the
 304    only supported subtype relationships are is that any pointer type is a
 305    subtype of (* t), and any array type first dimension will match
 306    (array <eltype> nil ...). Otherwise, the two types have to be
 307    ALIEN-TYPE-=."
 308   (or (eq type1 type2)
 309       (invoke-alien-type-method :subtypep type1 type2)))
 310
 311 (defun compute-naturalize-lambda (type)
 312   `(lambda (alien ignore)
 313      (declare (ignore ignore))
 314      ,(invoke-alien-type-method :naturalize-gen type 'alien)))
 315
 316 (defun compute-deport-lambda (type)
 317   (declare (type alien-type type))
 318   (/noshow "entering COMPUTE-DEPORT-LAMBDA" type)
 319   (multiple-value-bind (form value-type)
 320       (invoke-alien-type-method :deport-gen type 'value)
 321     `(lambda (value ignore)
 322        (declare (type ,(or value-type
 323                            (compute-lisp-rep-type type)
 324                            `(alien ,type))
 325                       value)
 326                 (ignore ignore))
 327        ,form)))
 328
 329 (defun compute-deport-alloc-lambda (type)
 330   `(lambda (value ignore)
 331      (declare (ignore ignore))
 332      ,(invoke-alien-type-method :deport-alloc-gen type 'value)))
 333
 334 (defun compute-extract-lambda (type)
 335   `(lambda (sap offset ignore)
 336      (declare (type system-area-pointer sap)
 337               (type unsigned-byte offset)
 338               (ignore ignore))
 339      (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
 340                  ',type)))
 341
 342 (defun compute-deposit-lambda (type)
 343   (declare (type alien-type type))
 344   `(lambda (value sap offset ignore)
 345      (declare (type system-area-pointer sap)
 346               (type unsigned-byte offset)
 347               (ignore ignore))
 348      (let ((alloc-tmp (deport-alloc value ',type)))
 349        (maybe-with-pinned-objects (alloc-tmp) (,type)
 350          (let ((value (deport alloc-tmp  ',type)))
 351            ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
 352            ;; Note: the reason we don't just return the pre-deported value
 353            ;; is because that would inhibit any (deport (naturalize ...))
 354            ;; optimizations that might have otherwise happen. Re-naturalizing
 355            ;; the value might cause extra consing, but is flushable, so probably
 356            ;; results in better code.
 357            (naturalize value ',type))))))
 358
 359 (defun compute-lisp-rep-type (type)
 360   (invoke-alien-type-method :lisp-rep type))
 361
 362 ;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function
 363 ;;; return values).  See the :ALIEN-REP method for INTEGER for
 364 ;;; details.
 365 (defun compute-alien-rep-type (type &optional (context :normal))
 366   (invoke-alien-type-method :alien-rep type context))
 367 \f
 368 ;;;; default methods
 369
 370 (define-alien-type-method (root :unparse) (type)
 371   `(<unknown-alien-type> ,(type-of type)))
 372
 373 (define-alien-type-method (root :type=) (type1 type2)
 374   (declare (ignore type1 type2))
 375   t)
 376
 377 (define-alien-type-method (root :subtypep) (type1 type2)
 378   (alien-type-= type1 type2))
 379
 380 (define-alien-type-method (root :lisp-rep) (type)
 381   (declare (ignore type))
 382   nil)
 383
 384 (define-alien-type-method (root :alien-rep) (type context)
 385   (declare (ignore type context))
 386   '*)
 387
 388 (define-alien-type-method (root :naturalize-gen) (type alien)
 389   (declare (ignore alien))
 390   (error "cannot represent ~S typed aliens" type))
 391
 392 (define-alien-type-method (root :deport-gen) (type object)
 393   (declare (ignore object))
 394   (error "cannot represent ~S typed aliens" type))
 395
 396 (define-alien-type-method (root :deport-alloc-gen) (type object)
 397   (declare (ignore type))
 398   object)
 399
 400 (define-alien-type-method (root :deport-pin-p) (type)
 401   (declare (ignore type))
 402   ;; Override this method to return T for classes which take a SAP to a
 403   ;; GCable lisp object when deporting.
 404   nil)
 405
 406 (define-alien-type-method (root :extract-gen) (type sap offset)
 407   (declare (ignore sap offset))
 408   (error "cannot represent ~S typed aliens" type))
 409
 410 (define-alien-type-method (root :deposit-gen) (type sap offset value)
 411   `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value))
 412
 413 (define-alien-type-method (root :arg-tn) (type state)
 414   (declare (ignore state))
 415   (error "Aliens of type ~S cannot be passed as arguments to CALL-OUT."
 416          (unparse-alien-type type)))
 417
 418 (define-alien-type-method (root :result-tn) (type state)
 419   (declare (ignore state))
 420   (error "Aliens of type ~S cannot be returned from CALL-OUT."
 421          (unparse-alien-type type)))
 422 \f
 423 ;;;; the INTEGER type
 424
 425 (define-alien-type-class (integer)
 426   (signed t :type (member t nil)))
 427
 428 (define-alien-type-translator signed (&optional (bits sb!vm:n-word-bits))
 429   (make-alien-integer-type :bits bits))
 430
 431 (define-alien-type-translator integer (&optional (bits sb!vm:n-word-bits))
 432   (make-alien-integer-type :bits bits))
 433
 434 (define-alien-type-translator unsigned (&optional (bits sb!vm:n-word-bits))
 435   (make-alien-integer-type :bits bits :signed nil))
 436
 437 (define-alien-type-method (integer :unparse) (type)
 438   (list (if (alien-integer-type-signed type) 'signed 'unsigned)
 439         (alien-integer-type-bits type)))
 440
 441 (define-alien-type-method (integer :type=) (type1 type2)
 442   (and (eq (alien-integer-type-signed type1)
 443            (alien-integer-type-signed type2))
 444        (= (alien-integer-type-bits type1)
 445           (alien-integer-type-bits type2))))
 446
 447 (define-alien-type-method (integer :lisp-rep) (type)
 448   (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 449         (alien-integer-type-bits type)))
 450
 451 (define-alien-type-method (integer :alien-rep) (type context)
 452   ;; When returning integer values that are narrower than a machine
 453   ;; register from a function, some platforms leave the higher bits of
 454   ;; the register uninitialized.  On those platforms, we use an
 455   ;; alien-rep of the full register width when checking for purposes
 456   ;; of return values and override the naturalize method to perform
 457   ;; the sign extension (in compiler/target/c-call.lisp).
 458   (ecase context
 459     ((:normal #!-(or alpha x86 x86-64) :result)
 460      (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 461            (alien-integer-type-bits type)))
 462     #!+(or alpha x86 x86-64)
 463     (:result
 464      (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 465            (max (alien-integer-type-bits type)
 466                 sb!vm:n-machine-word-bits)))))
 467
 468 ;;; As per the comment in the :ALIEN-REP method above, this is defined
 469 ;;; elsewhere for alpha and x86oids.
 470 #!-(or alpha x86 x86-64)
 471 (define-alien-type-method (integer :naturalize-gen) (type alien)
 472   (declare (ignore type))
 473   alien)
 474
 475 (define-alien-type-method (integer :deport-gen) (type value)
 476   (declare (ignore type))
 477   value)
 478
 479 (define-alien-type-method (integer :extract-gen) (type sap offset)
 480   (declare (type alien-integer-type type))
 481   (let ((ref-fun
 482          (if (alien-integer-type-signed type)
 483           (case (alien-integer-type-bits type)
 484             (8 'signed-sap-ref-8)
 485             (16 'signed-sap-ref-16)
 486             (32 'signed-sap-ref-32)
 487             (64 'signed-sap-ref-64))
 488           (case (alien-integer-type-bits type)
 489             (8 'sap-ref-8)
 490             (16 'sap-ref-16)
 491             (32 'sap-ref-32)
 492             (64 'sap-ref-64)))))
 493     (if ref-fun
 494         `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits))
 495         (error "cannot extract ~W-bit integers"
 496                (alien-integer-type-bits type)))))
 497 \f
 498 ;;;; the BOOLEAN type
 499
 500 (define-alien-type-class (boolean :include integer :include-args (signed)))
 501
 502 ;;; FIXME: Check to make sure that we aren't attaching user-readable
 503 ;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance.
 504 (define-alien-type-translator boolean (&optional (bits sb!vm:n-word-bits))
 505   (make-alien-boolean-type :bits bits :signed nil))
 506
 507 (define-alien-type-method (boolean :unparse) (type)
 508   `(boolean ,(alien-boolean-type-bits type)))
 509
 510 (define-alien-type-method (boolean :lisp-rep) (type)
 511   (declare (ignore type))
 512   `(member t nil))
 513
 514 (define-alien-type-method (boolean :naturalize-gen) (type alien)
 515   (let ((bits (alien-boolean-type-bits type)))
 516     (if (= bits sb!vm:n-word-bits)
 517         `(not (zerop ,alien))
 518         `(logtest ,alien ,(ldb (byte bits 0) -1)))))
 519
 520 (define-alien-type-method (boolean :deport-gen) (type value)
 521   (declare (ignore type))
 522   `(if ,value 1 0))
 523 \f
 524 ;;;; the ENUM type
 525
 526 (define-alien-type-class (enum :include (integer (bits 32))
 527                                :include-args (signed))
 528   name          ; name of this enum (if any)
 529   from          ; alist from symbols to integers
 530   to            ; alist or vector from integers to symbols
 531   kind          ; kind of from mapping, :VECTOR or :ALIST
 532   offset)       ; offset to add to value for :VECTOR from mapping
 533
 534 (define-alien-type-translator enum (&whole
 535                                  type name
 536                                  &rest mappings
 537                                  &environment env)
 538   (cond (mappings
 539          (let ((result (parse-enum name mappings)))
 540            (when name
 541              (multiple-value-bind (old old-p)
 542                  (auxiliary-alien-type :enum name env)
 543                (when old-p
 544                  (unless (alien-type-= result old)
 545                    (cerror "Continue, clobbering the old definition"
 546                            "Incompatible alien enum type definition: ~S" name)
 547                    (setf (alien-enum-type-from old) (alien-enum-type-from result)
 548                          (alien-enum-type-to old) (alien-enum-type-to result)
 549                          (alien-enum-type-kind old) (alien-enum-type-kind result)
 550                          (alien-enum-type-offset old) (alien-enum-type-offset result)
 551                          (alien-enum-type-signed old) (alien-enum-type-signed result)))
 552                  (setf result old))
 553                (unless old-p
 554                  (setf (auxiliary-alien-type :enum name env) result))))
 555            result))
 556         (name
 557          (multiple-value-bind (result found)
 558              (auxiliary-alien-type :enum name env)
 559            (unless found
 560              (error "unknown enum type: ~S" name))
 561            result))
 562         (t
 563          (error "empty enum type: ~S" type))))
 564
 565 (defun parse-enum (name elements)
 566   (when (null elements)
 567     (error "An enumeration must contain at least one element."))
 568   (let ((min nil)
 569         (max nil)
 570         (from-alist ())
 571         (prev -1))
 572     (declare (list from-alist))
 573     (dolist (el elements)
 574       (multiple-value-bind (sym val)
 575           (if (listp el)
 576               (values (first el) (second el))
 577               (values el (1+ prev)))
 578         (setf prev val)
 579         (unless (symbolp sym)
 580           (error "The enumeration element ~S is not a symbol." sym))
 581         (unless (integerp val)
 582           (error "The element value ~S is not an integer." val))
 583         (unless (and max (> max val)) (setq max val))
 584         (unless (and min (< min val)) (setq min val))
 585         (when (rassoc val from-alist)
 586           (style-warn "The element value ~S is used more than once." val))
 587         (when (assoc sym from-alist :test #'eq)
 588           (error "The enumeration element ~S is used more than once." sym))
 589         (push (cons sym val) from-alist)))
 590     (let* ((signed (minusp min))
 591            (min-bits (if signed
 592                          (1+ (max (integer-length min)
 593                                   (integer-length max)))
 594                          (integer-length max))))
 595       (when (> min-bits 32)
 596         (error "can't represent enums needing more than 32 bits"))
 597       (setf from-alist (sort from-alist #'< :key #'cdr))
 598       (cond
 599        ;; If range is at least 20% dense, use vector mapping. Crossover
 600        ;; point solely on basis of space would be 25%. Vector mapping
 601        ;; is always faster, so give the benefit of the doubt.
 602        ((< 0.2 (/ (float (length from-alist)) (float (1+ (- max min)))))
 603         ;; If offset is small and ignorable, ignore it to save time.
 604         (when (< 0 min 10) (setq min 0))
 605         (let ((to (make-array (1+ (- max min)))))
 606           (dolist (el from-alist)
 607             (setf (svref to (- (cdr el) min)) (car el)))
 608           (make-alien-enum-type :name name :signed signed
 609                                 :from from-alist :to to :kind
 610                                 :vector :offset (- min))))
 611        (t
 612         (make-alien-enum-type :name name :signed signed
 613                               :from from-alist
 614                               :to (mapcar (lambda (x) (cons (cdr x) (car x)))
 615                                           from-alist)
 616                               :kind :alist))))))
 617
 618 (define-alien-type-method (enum :unparse) (type)
 619   `(enum ,(alien-enum-type-name type)
 620          ,@(let ((prev -1))
 621              (mapcar (lambda (mapping)
 622                        (let ((sym (car mapping))
 623                              (value (cdr mapping)))
 624                          (prog1
 625                              (if (= (1+ prev) value)
 626                                  sym
 627                                  `(,sym ,value))
 628                            (setf prev value))))
 629                      (alien-enum-type-from type)))))
 630
 631 (define-alien-type-method (enum :type=) (type1 type2)
 632   (and (eq (alien-enum-type-name type1)
 633            (alien-enum-type-name type2))
 634        (equal (alien-enum-type-from type1)
 635               (alien-enum-type-from type2))))
 636
 637 (define-alien-type-method (enum :lisp-rep) (type)
 638   `(member ,@(mapcar #'car (alien-enum-type-from type))))
 639
 640 (define-alien-type-method (enum :naturalize-gen) (type alien)
 641   (ecase (alien-enum-type-kind type)
 642     (:vector
 643      `(svref ',(alien-enum-type-to type)
 644              (+ ,alien ,(alien-enum-type-offset type))))
 645     (:alist
 646      `(ecase ,alien
 647         ,@(mapcar (lambda (mapping)
 648                     `(,(car mapping) ',(cdr mapping)))
 649                   (alien-enum-type-to type))))))
 650
 651 (define-alien-type-method (enum :deport-gen) (type value)
 652   `(ecase ,value
 653      ,@(mapcar (lambda (mapping)
 654                  `(,(car mapping) ,(cdr mapping)))
 655                (alien-enum-type-from type))))
 656 \f
 657 ;;;; the FLOAT types
 658
 659 (define-alien-type-class (float)
 660   (type (missing-arg) :type symbol))
 661
 662 (define-alien-type-method (float :unparse) (type)
 663   (alien-float-type-type type))
 664
 665 (define-alien-type-method (float :lisp-rep) (type)
 666   (alien-float-type-type type))
 667
 668 (define-alien-type-method (float :alien-rep) (type context)
 669   (declare (ignore context))
 670   (alien-float-type-type type))
 671
 672 (define-alien-type-method (float :naturalize-gen) (type alien)
 673   (declare (ignore type))
 674   alien)
 675
 676 (define-alien-type-method (float :deport-gen) (type value)
 677   (declare (ignore type))
 678   value)
 679
 680 (define-alien-type-class (single-float :include (float (bits 32))
 681                                        :include-args (type)))
 682
 683 (define-alien-type-translator single-float ()
 684   (make-alien-single-float-type :type 'single-float))
 685
 686 (define-alien-type-method (single-float :extract-gen) (type sap offset)
 687   (declare (ignore type))
 688   `(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits)))
 689
 690 (define-alien-type-class (double-float :include (float (bits 64))
 691                                        :include-args (type)))
 692
 693 (define-alien-type-translator double-float ()
 694   (make-alien-double-float-type :type 'double-float))
 695
 696 (define-alien-type-method (double-float :extract-gen) (type sap offset)
 697   (declare (ignore type))
 698   `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits)))
 699
 700 \f
 701 ;;;; the POINTER type
 702
 703 (define-alien-type-class (pointer :include (alien-value (bits
 704                                                          sb!vm:n-machine-word-bits)))
 705   (to nil :type (or alien-type null)))
 706
 707 (define-alien-type-translator * (to &environment env)
 708   (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env))))
 709
 710 (define-alien-type-method (pointer :unparse) (type)
 711   (let ((to (alien-pointer-type-to type)))
 712     `(* ,(if to
 713              (%unparse-alien-type to)
 714              t))))
 715
 716 (define-alien-type-method (pointer :type=) (type1 type2)
 717   (let ((to1 (alien-pointer-type-to type1))
 718         (to2 (alien-pointer-type-to type2)))
 719     (if to1
 720         (if to2
 721             (alien-type-= to1 to2)
 722             nil)
 723         (null to2))))
 724
 725 (define-alien-type-method (pointer :subtypep) (type1 type2)
 726   (and (alien-pointer-type-p type2)
 727        (let ((to1 (alien-pointer-type-to type1))
 728              (to2 (alien-pointer-type-to type2)))
 729          (if to1
 730              (if to2
 731                  (alien-subtype-p to1 to2)
 732                  t)
 733              (null to2)))))
 734
 735 (define-alien-type-method (pointer :deport-gen) (type value)
 736   (/noshow "doing alien type method POINTER :DEPORT-GEN" type value)
 737   (values
 738    ;; FIXME: old version, highlighted a bug in xc optimization
 739    `(etypecase ,value
 740       (null
 741        (int-sap 0))
 742       (system-area-pointer
 743        ,value)
 744       ((alien ,type)
 745        (alien-sap ,value)))
 746    ;; new version, works around bug in xc optimization
 747    #+nil
 748    `(etypecase ,value
 749       (system-area-pointer
 750        ,value)
 751       ((alien ,type)
 752        (alien-sap ,value))
 753       (null
 754        (int-sap 0)))
 755    `(or null system-area-pointer (alien ,type))))
 756 \f
 757 ;;;; the MEM-BLOCK type
 758
 759 (define-alien-type-class (mem-block :include alien-value))
 760
 761 (define-alien-type-method (mem-block :extract-gen) (type sap offset)
 762   (declare (ignore type))
 763   `(sap+ ,sap (truncate ,offset sb!vm:n-byte-bits)))
 764
 765 (define-alien-type-method (mem-block :deposit-gen) (type sap offset value)
 766   (let ((bits (alien-mem-block-type-bits type)))
 767     (unless bits
 768       (error "can't deposit aliens of type ~S (unknown size)" type))
 769     `(sb!kernel:system-area-ub8-copy ,value 0 ,sap
 770       (truncate ,offset sb!vm:n-byte-bits)
 771       ',(truncate bits sb!vm:n-byte-bits))))
 772 \f
 773 ;;;; the ARRAY type
 774
 775 (define-alien-type-class (array :include mem-block)
 776   (element-type (missing-arg) :type alien-type)
 777   (dimensions (missing-arg) :type list))
 778
 779 (define-alien-type-translator array (ele-type &rest dims &environment env)
 780
 781   (when dims
 782     (unless (typep (first dims) '(or index null))
 783       (error "The first dimension is not a non-negative fixnum or NIL: ~S"
 784              (first dims)))
 785     (let ((loser (find-if-not (lambda (x) (typep x 'index))
 786                               (rest dims))))
 787       (when loser
 788         (error "A dimension is not a non-negative fixnum: ~S" loser))))
 789
 790   (let ((parsed-ele-type (parse-alien-type ele-type env)))
 791     (make-alien-array-type
 792      :element-type parsed-ele-type
 793      :dimensions dims
 794      :alignment (alien-type-alignment parsed-ele-type)
 795      :bits (if (and (alien-type-bits parsed-ele-type)
 796                     (every #'integerp dims))
 797                (* (align-offset (alien-type-bits parsed-ele-type)
 798                                 (alien-type-alignment parsed-ele-type))
 799                   (reduce #'* dims))))))
 800
 801 (define-alien-type-method (array :unparse) (type)
 802   `(array ,(%unparse-alien-type (alien-array-type-element-type type))
 803           ,@(alien-array-type-dimensions type)))
 804
 805 (define-alien-type-method (array :type=) (type1 type2)
 806   (and (equal (alien-array-type-dimensions type1)
 807               (alien-array-type-dimensions type2))
 808        (alien-type-= (alien-array-type-element-type type1)
 809                      (alien-array-type-element-type type2))))
 810
 811 (define-alien-type-method (array :subtypep) (type1 type2)
 812   (and (alien-array-type-p type2)
 813        (let ((dim1 (alien-array-type-dimensions type1))
 814              (dim2 (alien-array-type-dimensions type2)))
 815          (and (= (length dim1) (length dim2))
 816               (or (and dim2
 817                        (null (car dim2))
 818                        (equal (cdr dim1) (cdr dim2)))
 819                   (equal dim1 dim2))
 820               (alien-subtype-p (alien-array-type-element-type type1)
 821                                (alien-array-type-element-type type2))))))
 822 \f
 823 ;;;; the RECORD type
 824
 825 (def!struct (alien-record-field
 826              (:make-load-form-fun sb!kernel:just-dump-it-normally))
 827   (name (missing-arg) :type symbol)
 828   (type (missing-arg) :type alien-type)
 829   (bits nil :type (or unsigned-byte null))
 830   (offset 0 :type unsigned-byte))
 831 (def!method print-object ((field alien-record-field) stream)
 832   (print-unreadable-object (field stream :type t)
 833     (format stream
 834             "~S ~S~@[:~D~]"
 835             (alien-record-field-type field)
 836             (alien-record-field-name field)
 837             (alien-record-field-bits field))))
 838
 839 (define-alien-type-class (record :include mem-block)
 840   (kind :struct :type (member :struct :union))
 841   (name nil :type (or symbol null))
 842   (fields nil :type list))
 843
 844 (define-alien-type-translator struct (name &rest fields &environment env)
 845   (parse-alien-record-type :struct name fields env))
 846
 847 (define-alien-type-translator union (name &rest fields &environment env)
 848   (parse-alien-record-type :union name fields env))
 849
 850 ;;; FIXME: This is really pretty horrible: we avoid creating new
 851 ;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the
 852 ;;; system already. This way forward-references sans fields get
 853 ;;; "updated" for free to contain the field info. Maybe rename
 854 ;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use
 855 ;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729
 856 (defun parse-alien-record-type (kind name fields env)
 857   (declare (type sb!kernel:lexenv-designator env))
 858   (flet ((frob-type (type new-fields alignment bits)
 859            (setf (alien-record-type-fields type) new-fields
 860                  (alien-record-type-alignment type) alignment
 861                  (alien-record-type-bits type) bits)))
 862       (cond (fields
 863              (multiple-value-bind (new-fields alignment bits)
 864                  (parse-alien-record-fields kind fields env)
 865                (let* ((old (and name (auxiliary-alien-type kind name env)))
 866                       (old-fields (and old (alien-record-type-fields old))))
 867                  (when (and old-fields
 868                             (notevery #'record-fields-match-p old-fields new-fields))
 869                    (cerror "Continue, clobbering the old definition."
 870                            "Incompatible alien record type definition~%Old: ~S~%New: ~S"
 871                            (unparse-alien-type old)
 872                            `(,(unparse-alien-record-kind kind)
 873                               ,name
 874                              ,@(let ((*record-types-already-unparsed* '()))
 875                                  (mapcar #'unparse-alien-record-field new-fields))))
 876                    (frob-type old new-fields alignment bits))
 877                  (if old-fields
 878                      old
 879                      (let ((type (or old (make-alien-record-type :name name :kind kind))))
 880                        (when (and name (not old))
 881                          (setf (auxiliary-alien-type kind name env) type))
 882                        (frob-type type new-fields alignment bits)
 883                        type)))))
 884             (name
 885              (or (auxiliary-alien-type kind name env)
 886                  (setf (auxiliary-alien-type kind name env)
 887                        (make-alien-record-type :name name :kind kind))))
 888             (t
 889              (make-alien-record-type :kind kind)))))
 890
 891 ;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union
 892 ;;; types. KIND is the kind we are paring the fields of, and FIELDS is the
 893 ;;; list of field specifications.
 894 ;;;
 895 ;;; Result is a list of field objects, overall alignment, and number of bits
 896 (defun parse-alien-record-fields (kind fields env)
 897   (declare (type list fields))
 898   (let ((total-bits 0)
 899         (overall-alignment 1)
 900         (parsed-fields nil))
 901     (dolist (field fields)
 902       (destructuring-bind (var type &key alignment bits offset) field
 903         (declare (ignore bits))
 904         (let* ((field-type (parse-alien-type type env))
 905                (bits (alien-type-bits field-type))
 906                (parsed-field
 907                 (make-alien-record-field :type field-type
 908                                          :name var)))
 909           (unless alignment
 910             (setf alignment (alien-type-alignment field-type)))
 911           (push parsed-field parsed-fields)
 912           (when (null bits)
 913             (error "unknown size: ~S" (unparse-alien-type field-type)))
 914           (when (null alignment)
 915             (error "unknown alignment: ~S" (unparse-alien-type field-type)))
 916           (setf overall-alignment (max overall-alignment alignment))
 917           (ecase kind
 918             (:struct
 919              (let ((offset (or offset (align-offset total-bits alignment))))
 920                (setf (alien-record-field-offset parsed-field) offset)
 921                (setf total-bits (+ offset bits))))
 922             (:union
 923              (setf total-bits (max total-bits bits)))))))
 924     (values (nreverse parsed-fields)
 925             overall-alignment
 926             (align-offset total-bits overall-alignment))))
 927
 928 (define-alien-type-method (record :unparse) (type)
 929   `(,(unparse-alien-record-kind (alien-record-type-kind type))
 930     ,(alien-record-type-name type)
 931     ,@(unless (member type *record-types-already-unparsed* :test #'eq)
 932         (push type *record-types-already-unparsed*)
 933         (mapcar #'unparse-alien-record-field
 934                 (alien-record-type-fields type)))))
 935
 936 (defun unparse-alien-record-kind (kind)
 937   (case kind
 938     (:struct 'struct)
 939     (:union 'union)
 940     (t '???)))
 941
 942 (defun unparse-alien-record-field (field)
 943   `(,(alien-record-field-name field)
 944      ,(%unparse-alien-type (alien-record-field-type field))
 945      ,@(when (alien-record-field-bits field)
 946              (list :bits (alien-record-field-bits field)))
 947      ,@(when (alien-record-field-offset field)
 948              (list :offset (alien-record-field-offset field)))))
 949
 950 ;;; Test the record fields. Keep a hashtable table of already compared
 951 ;;; types to detect cycles.
 952 (defun record-fields-match-p (field1 field2)
 953   (and (eq (alien-record-field-name field1)
 954            (alien-record-field-name field2))
 955        (eql (alien-record-field-bits field1)
 956             (alien-record-field-bits field2))
 957        (eql (alien-record-field-offset field1)
 958             (alien-record-field-offset field2))
 959        (alien-type-= (alien-record-field-type field1)
 960                      (alien-record-field-type field2))))
 961
 962 (defvar *alien-type-matches* nil
 963   #!+sb-doc
 964   "A hashtable used to detect cycles while comparing record types.")
 965
 966 (define-alien-type-method (record :type=) (type1 type2)
 967   (and (eq (alien-record-type-name type1)
 968            (alien-record-type-name type2))
 969        (eq (alien-record-type-kind type1)
 970            (alien-record-type-kind type2))
 971        (eql (alien-type-bits type1)
 972             (alien-type-bits type2))
 973        (eql (alien-type-alignment type1)
 974             (alien-type-alignment type2))
 975        (flet ((match-fields (&optional old)
 976                 (setf (gethash type1 *alien-type-matches*) (cons type2 old))
 977                 (every #'record-fields-match-p
 978                        (alien-record-type-fields type1)
 979                        (alien-record-type-fields type2))))
 980          (if *alien-type-matches*
 981              (let ((types (gethash type1 *alien-type-matches*)))
 982                (or (memq type2 types) (match-fields types)))
 983              (let ((*alien-type-matches* (make-hash-table :test #'eq)))
 984                (match-fields))))))
 985 \f
 986 ;;;; the FUNCTION and VALUES alien types
 987
 988 ;;; Calling-convention spec, typically one of predefined keywords.
 989 ;;; Add or remove as needed for target platform.  It makes sense to
 990 ;;; support :cdecl everywhere.
 991 ;;;
 992 ;;; Null convention is supposed to be platform-specific most-universal
 993 ;;; callout convention. For x86, SBCL calls foreign functions in a way
 994 ;;; allowing them to be either stdcall or cdecl; null convention is
 995 ;;; appropriate here, as it is for specifying callbacks that could be
 996 ;;; accepted by foreign code both in cdecl and stdcall form.
 997 (def!type calling-convention () `(or null (member :stdcall :cdecl)))
 998
 999 ;;; Convention could be a values type class, stored at result-type.
1000 ;;; However, it seems appropriate only for epilogue-related
1001 ;;; conventions, those not influencing incoming arg passing.
1002 ;;;
1003 ;;; As of x86's :stdcall and :cdecl, supported by now, both are
1004 ;;; epilogue-related, but future extensions (like :fastcall and
1005 ;;; miscellaneous non-x86 stuff) might affect incoming argument
1006 ;;; translation as well.
1007
1008 (define-alien-type-class (fun :include mem-block)
1009   (result-type (missing-arg) :type alien-type)
1010   (arg-types (missing-arg) :type list)
1011   (stub nil :type (or null function))
1012   (convention nil :type calling-convention))
1013
1014 ;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
1015 ;;; convention specification for function types is unobvious.
1016 ;;;
1017 ;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
1018 ;;; starting with a convention keyword; its second item is a real
1019 ;;; result-type in this case. If convention is ever to become a part
1020 ;;; of result-type, such a syntax can be retained.
1021
1022 (define-alien-type-translator function (result-type &rest arg-types
1023                                                     &environment env)
1024   (multiple-value-bind (bare-result-type calling-convention)
1025       (typecase result-type
1026         ((cons calling-convention *)
1027            (values (second result-type) (first result-type)))
1028         (t result-type))
1029     (make-alien-fun-type
1030      :convention calling-convention
1031      :result-type (let ((*values-type-okay* t))
1032                     (parse-alien-type bare-result-type env))
1033      :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
1034                         arg-types))))
1035
1036 (define-alien-type-method (fun :unparse) (type)
1037   `(function ,(let ((result-type
1038                      (%unparse-alien-type (alien-fun-type-result-type type)))
1039                     (convention (alien-fun-type-convention type)))
1040                 (if convention (list convention result-type)
1041                     result-type))
1042              ,@(mapcar #'%unparse-alien-type
1043                        (alien-fun-type-arg-types type))))
1044
1045 (define-alien-type-method (fun :type=) (type1 type2)
1046   (and (alien-type-= (alien-fun-type-result-type type1)
1047                      (alien-fun-type-result-type type2))
1048        (eq (alien-fun-type-convention type1)
1049            (alien-fun-type-convention type2))
1050        (= (length (alien-fun-type-arg-types type1))
1051           (length (alien-fun-type-arg-types type2)))
1052        (every #'alien-type-=
1053               (alien-fun-type-arg-types type1)
1054               (alien-fun-type-arg-types type2))))
1055
1056 (define-alien-type-class (values)
1057   (values (missing-arg) :type list))
1058
1059 (define-alien-type-translator values (&rest values &environment env)
1060   (unless *values-type-okay*
1061     (error "cannot use values types here"))
1062   (let ((*values-type-okay* nil))
1063     (make-alien-values-type
1064      :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env))
1065                      values))))
1066
1067 (define-alien-type-method (values :unparse) (type)
1068   `(values ,@(mapcar #'%unparse-alien-type
1069                      (alien-values-type-values type))))
1070
1071 (define-alien-type-method (values :type=) (type1 type2)
1072   (and (= (length (alien-values-type-values type1))
1073           (length (alien-values-type-values type2)))
1074        (every #'alien-type-=
1075               (alien-values-type-values type1)
1076               (alien-values-type-values type2))))
1077 \f
1078 ;;;; a structure definition needed both in the target and in the
1079 ;;;; cross-compilation host
1080
1081 ;;; information about local aliens. The WITH-ALIEN macro builds one of
1082 ;;; these structures and LOCAL-ALIEN and friends communicate
1083 ;;; information about how that local alien is represented.
1084 (def!struct (local-alien-info
1085              (:make-load-form-fun sb!kernel:just-dump-it-normally)
1086              (:constructor make-local-alien-info
1087                            (&key type force-to-memory-p
1088                             &aux (force-to-memory-p (or force-to-memory-p
1089                                                         (alien-array-type-p type)
1090                                                         (alien-record-type-p type))))))
1091   ;; the type of the local alien
1092   (type (missing-arg) :type alien-type)
1093   ;; Must this local alien be forced into memory? Using the ADDR macro
1094   ;; on a local alien will set this.
1095   (force-to-memory-p nil :type (member t nil)))
1096 (def!method print-object ((info local-alien-info) stream)
1097   (print-unreadable-object (info stream :type t)
1098     (format stream
1099             "~:[~;(forced to stack) ~]~S"
1100             (local-alien-info-force-to-memory-p info)
1101             (unparse-alien-type (local-alien-info-type info)))))
1102 \f
1103 ;;;; the ADDR macro
1104
1105 (sb!xc:defmacro addr (expr &environment env)
1106   #!+sb-doc
1107   "Return an Alien pointer to the data addressed by Expr, which must be a call
1108    to SLOT or DEREF, or a reference to an Alien variable."
1109   (let ((form (%macroexpand expr env)))
1110     (or (typecase form
1111           (cons
1112            (case (car form)
1113              (slot
1114               (cons '%slot-addr (cdr form)))
1115              (deref
1116               (cons '%deref-addr (cdr form)))
1117              (%heap-alien
1118               (cons '%heap-alien-addr (cdr form)))
1119              (local-alien
1120               (let ((info (let ((info-arg (second form)))
1121                             (and (consp info-arg)
1122                                  (eq (car info-arg) 'quote)
1123                                  (second info-arg)))))
1124                 (unless (local-alien-info-p info)
1125                   (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S"
1126                          form))
1127                 (setf (local-alien-info-force-to-memory-p info) t))
1128               (cons '%local-alien-addr (cdr form)))))
1129           (symbol
1130            (let ((kind (info :variable :kind form)))
1131              (when (eq kind :alien)
1132                `(%heap-alien-addr ',(info :variable :alien-info form))))))
1133         (error "~S is not a valid L-value." form))))
1134
1135 (/show0 "host-alieneval.lisp end of file")