X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=c78853fe332c88ffd9c1eb4e2065fb166db48feb;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=dea6d47ceb5e2852f4c2786a32abe53d35e7271f;hpb=9015efbd1be6387a31514c2abd4dbdba4330d2a7;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index dea6d47..c78853f 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -34,6 +34,7 @@ (defstruct (alien-type-class (:copier nil)) (name nil :type symbol) + (defstruct-name nil :type symbol) (include nil :type (or null alien-type-class)) (unparse nil :type (or null function)) (type= nil :type (or null function)) @@ -43,6 +44,8 @@ (deposit-gen nil :type (or null function)) (naturalize-gen nil :type (or null function)) (deport-gen nil :type (or null function)) + (deport-alloc-gen nil :type (or null function)) + (deport-pin-p nil :type (or null function)) ;; Cast? (arg-tn nil :type (or null function)) (result-tn nil :type (or null function)) @@ -55,13 +58,15 @@ (or (gethash name *alien-type-classes*) (error "no alien type class ~S" name))) -(defun create-alien-type-class-if-necessary (name include) +(defun create-alien-type-class-if-necessary (name defstruct-name include) (let ((old (gethash name *alien-type-classes*)) (include (and include (alien-type-class-or-lose include)))) (if old (setf (alien-type-class-include old) include) (setf (gethash name *alien-type-classes*) - (make-alien-type-class :name name :include include))))) + (make-alien-type-class :name name + :defstruct-name defstruct-name + :include include))))) (defparameter *method-slot-alist* '((:unparse . alien-type-class-unparse) @@ -73,6 +78,8 @@ (:deposit-gen . alien-type-class-deposit-gen) (:naturalize-gen . alien-type-class-naturalize-gen) (:deport-gen . alien-type-class-deport-gen) + (:deport-alloc-gen . alien-type-class-deport-alloc-gen) + (:deport-pin-p . alien-type-class-deport-pin-p) ;; cast? (:arg-tn . alien-type-class-arg-tn) (:result-tn . alien-type-class-result-tn))) @@ -95,16 +102,19 @@ (symbol (values include - (symbolicate "ALIEN-" include "-TYPE") + (alien-type-class-defstruct-name + (alien-type-class-or-lose include)) nil)) (list (values (car include) - (symbolicate "ALIEN-" (car include) "-TYPE") + (alien-type-class-defstruct-name + (alien-type-class-or-lose (car include))) (cdr include)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (create-alien-type-class-if-necessary ',name ',(or include 'root))) + (create-alien-type-class-if-necessary ',name ',defstruct-name + ',(or include 'root))) (def!struct (,defstruct-name (:include ,include-defstruct (class ',name) @@ -150,7 +160,7 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun auxiliary-type-definitions (env) (multiple-value-bind (result expanded-p) - (sb!xc:macroexpand '&auxiliary-type-definitions& env) + (%macroexpand '&auxiliary-type-definitions& env) (if expanded-p result ;; This is like having the global symbol-macro definition be @@ -281,9 +291,6 @@ `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) ,@(when name `((%define-alien-type ',name ',alien-type))))))) -(def!macro def-alien-type (&rest rest) - (deprecation-warning 'def-alien-type 'define-alien-type) - `(define-alien-type ,@rest)) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %def-auxiliary-alien-types (types) @@ -328,7 +335,7 @@ ;;;; the root alien type (eval-when (:compile-toplevel :load-toplevel :execute) - (create-alien-type-class-if-necessary 'root nil)) + (create-alien-type-class-if-necessary 'root 'alien-type nil)) (def!struct (alien-type (:make-load-form-fun sb!kernel:just-dump-it-normally) @@ -357,8 +364,8 @@ (declare (ignore type)) 'system-area-pointer) -(define-alien-type-method (system-area-pointer :alien-rep) (type) - (declare (ignore type)) +(define-alien-type-method (system-area-pointer :alien-rep) (type context) + (declare (ignore type context)) 'system-area-pointer) (define-alien-type-method (system-area-pointer :naturalize-gen) (type alien) @@ -397,15 +404,27 @@ (:make-load-form-fun sb!kernel:just-dump-it-normally)) ;; The type of this alien. (type (missing-arg) :type alien-type) - ;; The form to evaluate to produce the SAP pointing to where in the heap - ;; it is. - (sap-form (missing-arg))) + ;; Its name. + (alien-name (missing-arg) :type simple-string) + ;; Data or code? + (datap (missing-arg) :type boolean)) (def!method print-object ((info heap-alien-info) stream) (print-unreadable-object (info stream :type t) - (funcall (formatter "~S ~S") + (funcall (formatter "~S ~S~@[ (data)~]") stream - (heap-alien-info-sap-form info) - (unparse-alien-type (heap-alien-info-type info))))) + (heap-alien-info-alien-name info) + (unparse-alien-type (heap-alien-info-type info)) + (heap-alien-info-datap info)))) + +;;; The form to evaluate to produce the SAP pointing to where in the heap +;;; it is. +(defun heap-alien-info-sap-form (info) + `(foreign-symbol-sap ,(heap-alien-info-alien-name info) + ,(heap-alien-info-datap info))) + +(defun heap-alien-info-sap (info) + (foreign-symbol-sap (heap-alien-info-alien-name info) + (heap-alien-info-datap info))) ;;;; Interfaces to the different methods @@ -445,6 +464,11 @@ (ignore ignore)) ,form))) +(defun compute-deport-alloc-lambda (type) + `(lambda (value ignore) + (declare (ignore ignore)) + ,(invoke-alien-type-method :deport-alloc-gen type 'value))) + (defun compute-extract-lambda (type) `(lambda (sap offset ignore) (declare (type system-area-pointer sap) @@ -453,26 +477,48 @@ (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset) ',type))) +(def!macro maybe-with-pinned-objects (variables types &body body) + (declare (ignorable variables types)) + (let ((pin-variables + ;; Only pin things on GENCGC, since on CHENEYGC it'd imply + ;; disabling the GC. Which is something we don't want to do + ;; every time we're calling to C. + #!+gencgc + (loop for variable in variables + for type in types + when (invoke-alien-type-method :deport-pin-p type) + collect variable))) + (if pin-variables + `(with-pinned-objects ,pin-variables + ,@body) + `(progn + ,@body)))) + (defun compute-deposit-lambda (type) (declare (type alien-type type)) - `(lambda (sap offset ignore value) + `(lambda (value sap offset ignore) (declare (type system-area-pointer sap) (type unsigned-byte offset) (ignore ignore)) - (let ((value (deport value ',type))) - ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value) - ;; Note: the reason we don't just return the pre-deported value - ;; is because that would inhibit any (deport (naturalize ...)) - ;; optimizations that might have otherwise happen. Re-naturalizing - ;; the value might cause extra consing, but is flushable, so probably - ;; results in better code. - (naturalize value ',type)))) + (let ((alloc-tmp (deport-alloc value ',type))) + (maybe-with-pinned-objects (alloc-tmp) (,type) + (let ((value (deport alloc-tmp ',type))) + ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value) + ;; Note: the reason we don't just return the pre-deported value + ;; is because that would inhibit any (deport (naturalize ...)) + ;; optimizations that might have otherwise happen. Re-naturalizing + ;; the value might cause extra consing, but is flushable, so probably + ;; results in better code. + (naturalize value ',type)))))) (defun compute-lisp-rep-type (type) (invoke-alien-type-method :lisp-rep type)) -(defun compute-alien-rep-type (type) - (invoke-alien-type-method :alien-rep type)) +;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function +;;; return values). See the :ALIEN-REP method for INTEGER for +;;; details. +(defun compute-alien-rep-type (type &optional (context :normal)) + (invoke-alien-type-method :alien-rep type context)) ;;;; default methods @@ -490,8 +536,8 @@ (declare (ignore type)) nil) -(define-alien-type-method (root :alien-rep) (type) - (declare (ignore type)) +(define-alien-type-method (root :alien-rep) (type context) + (declare (ignore type context)) '*) (define-alien-type-method (root :naturalize-gen) (type alien) @@ -502,6 +548,16 @@ (declare (ignore object)) (error "cannot represent ~S typed aliens" type)) +(define-alien-type-method (root :deport-alloc-gen) (type object) + (declare (ignore type)) + object) + +(define-alien-type-method (root :deport-pin-p) (type) + (declare (ignore type)) + ;; Override this method to return T for classes which take a SAP to a + ;; GCable lisp object when deporting. + nil) + (define-alien-type-method (root :extract-gen) (type sap offset) (declare (ignore sap offset)) (error "cannot represent ~S typed aliens" type)) @@ -547,10 +603,25 @@ (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) (alien-integer-type-bits type))) -(define-alien-type-method (integer :alien-rep) (type) - (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) - (alien-integer-type-bits type))) - +(define-alien-type-method (integer :alien-rep) (type context) + ;; When returning integer values that are narrower than a machine + ;; register from a function, some platforms leave the higher bits of + ;; the register uninitialized. On those platforms, we use an + ;; alien-rep of the full register width when checking for purposes + ;; of return values and override the naturalize method to perform + ;; the sign extension (in compiler/target/c-call.lisp). + (ecase context + ((:normal #!-(or x86 x86-64) :result) + (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) + (alien-integer-type-bits type))) + #!+(or x86 x86-64) + (:result + (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) + sb!vm:n-word-bits)))) + +;;; As per the comment in the :ALIEN-REP method above, this is defined +;;; elsewhere for x86oids. +#!-(or x86 x86-64) (define-alien-type-method (integer :naturalize-gen) (type alien) (declare (ignore type)) alien) @@ -595,8 +666,10 @@ `(member t nil)) (define-alien-type-method (boolean :naturalize-gen) (type alien) - (declare (ignore type)) - `(not (zerop ,alien))) + (let ((bits (alien-boolean-type-bits type))) + (if (= bits sb!vm:n-word-bits) + `(not (zerop ,alien)) + `(logtest ,alien ,(ldb (byte bits 0) -1))))) (define-alien-type-method (boolean :deport-gen) (type value) (declare (ignore type)) @@ -623,8 +696,16 @@ (auxiliary-alien-type :enum name env) (when old-p (unless (alien-type-= result old) - (warn "redefining alien enum ~S" name)))) - (setf (auxiliary-alien-type :enum name env) result)) + (cerror "Continue, clobbering the old definition" + "Incompatible alien enum type definition: ~S" name) + (setf (alien-type-from old) (alien-type-from result) + (alien-type-to old) (alien-type-to result) + (alien-type-kind old) (alien-type-kind result) + (alien-type-offset old) (alien-type-offset result) + (alien-type-signed old) (alien-type-signed result))) + (setf result old)) + (unless old-p + (setf (auxiliary-alien-type :enum name env) result)))) result)) (name (multiple-value-bind (result found) @@ -738,7 +819,8 @@ (define-alien-type-method (float :lisp-rep) (type) (alien-float-type-type type)) -(define-alien-type-method (float :alien-rep) (type) +(define-alien-type-method (float :alien-rep) (type context) + (declare (ignore context)) (alien-float-type-type type)) (define-alien-type-method (float :naturalize-gen) (type alien) @@ -834,13 +916,15 @@ (define-alien-type-method (mem-block :extract-gen) (type sap offset) (declare (ignore type)) - `(sap+ ,sap (/ ,offset sb!vm:n-byte-bits))) + `(sap+ ,sap (truncate ,offset sb!vm:n-byte-bits))) (define-alien-type-method (mem-block :deposit-gen) (type sap offset value) - (let ((bytes (truncate (alien-mem-block-type-bits type) sb!vm:n-byte-bits))) - (unless bytes + (let ((bits (alien-mem-block-type-bits type))) + (unless bits (error "can't deposit aliens of type ~S (unknown size)" type)) - `(sb!kernel:system-area-ub8-copy ,value 0 ,sap ,offset ',bytes))) + `(sb!kernel:system-area-ub8-copy ,value 0 ,sap + (truncate ,offset sb!vm:n-byte-bits) + ',(truncate bits sb!vm:n-byte-bits)))) ;;;; the ARRAY type @@ -921,52 +1005,57 @@ ;;; FIXME: This is really pretty horrible: we avoid creating new ;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the -;;; system already. This way forwrd-references sans fields get get +;;; system already. This way forward-references sans fields get ;;; "updated" for free to contain the field info. Maybe rename ;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use ;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729 (defun parse-alien-record-type (kind name fields env) (declare (type (or sb!kernel:lexenv null) env)) - (cond (fields - (let* ((old (and name (auxiliary-alien-type kind name env))) - (old-fields (and old (alien-record-type-fields old)))) - ;; KLUDGE: We can't easily compare the new fields - ;; against the old fields, since the old fields have - ;; already been parsed into an internal - ;; representation, so we just punt, assuming that - ;; they're consistent. -- WHN 200000505 - #| - (unless (equal fields old-fields) - ;; FIXME: Perhaps this should be a warning, and we - ;; should overwrite the old definition and proceed? - (error "mismatch in fields for ~S~% old ~S~% new ~S" - name old-fields fields)) - |# - (if old-fields - old - (let ((type (or old (make-alien-record-type :name name :kind kind)))) - (when (and name (not old)) - (setf (auxiliary-alien-type kind name env) type)) - (parse-alien-record-fields type fields env) - type)))) - (name - (or (auxiliary-alien-type kind name env) - (setf (auxiliary-alien-type kind name env) - (make-alien-record-type :name name :kind kind)))) - (t - (make-alien-record-type :kind kind)))) - -;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and -;;; union types. RESULT holds the record type we are paring the fields -;;; of, and FIELDS is the list of field specifications. -(defun parse-alien-record-fields (result fields env) - (declare (type alien-record-type result) - (type list fields)) + (flet ((frob-type (type new-fields alignment bits) + (setf (alien-record-type-fields type) new-fields + (alien-record-type-alignment type) alignment + (alien-record-type-bits type) bits))) + (cond (fields + (multiple-value-bind (new-fields alignment bits) + (parse-alien-record-fields kind fields env) + (let* ((old (and name (auxiliary-alien-type kind name env))) + (old-fields (and old (alien-record-type-fields old)))) + (when (and old-fields + (notevery #'record-fields-match-p old-fields new-fields)) + (cerror "Continue, clobbering the old definition." + "Incompatible alien record type definition~%Old: ~S~%New: ~S" + (unparse-alien-type old) + `(,(unparse-alien-record-kind kind) + ,name + ,@(mapcar #'unparse-alien-record-field new-fields))) + (frob-type old new-fields alignment bits)) + (if old-fields + old + (let ((type (or old (make-alien-record-type :name name :kind kind)))) + (when (and name (not old)) + (setf (auxiliary-alien-type kind name env) type)) + (frob-type type new-fields alignment bits) + type))))) + (name + (or (auxiliary-alien-type kind name env) + (setf (auxiliary-alien-type kind name env) + (make-alien-record-type :name name :kind kind)))) + (t + (make-alien-record-type :kind kind))))) + +;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union +;;; types. KIND is the kind we are paring the fields of, and FIELDS is the +;;; list of field specifications. +;;; +;;; Result is a list of field objects, overall alignment, and number of bits +(defun parse-alien-record-fields (kind fields env) + (declare (type list fields)) (let ((total-bits 0) (overall-alignment 1) (parsed-fields nil)) (dolist (field fields) - (destructuring-bind (var type &key alignment) field + (destructuring-bind (var type &key alignment bits offset) field + (declare (ignore bits)) (let* ((field-type (parse-alien-type type env)) (bits (alien-type-bits field-type)) (parsed-field @@ -980,34 +1069,39 @@ (when (null alignment) (error "unknown alignment: ~S" (unparse-alien-type field-type))) (setf overall-alignment (max overall-alignment alignment)) - (ecase (alien-record-type-kind result) + (ecase kind (:struct - (let ((offset (align-offset total-bits alignment))) + (let ((offset (or offset (align-offset total-bits alignment)))) (setf (alien-record-field-offset parsed-field) offset) (setf total-bits (+ offset bits)))) (:union (setf total-bits (max total-bits bits))))))) - (let ((new (nreverse parsed-fields))) - (setf (alien-record-type-fields result) new)) - (setf (alien-record-type-alignment result) overall-alignment) - (setf (alien-record-type-bits result) - (align-offset total-bits overall-alignment)))) + (values (nreverse parsed-fields) + overall-alignment + (align-offset total-bits overall-alignment)))) (define-alien-type-method (record :unparse) (type) - `(,(case (alien-record-type-kind type) - (:struct 'struct) - (:union 'union) - (t '???)) + `(,(unparse-alien-record-kind (alien-record-type-kind type)) ,(alien-record-type-name type) ,@(unless (member type *record-types-already-unparsed* :test #'eq) (push type *record-types-already-unparsed*) - (mapcar (lambda (field) - `(,(alien-record-field-name field) - ,(%unparse-alien-type (alien-record-field-type field)) - ,@(if (alien-record-field-bits field) - (list (alien-record-field-bits field))))) + (mapcar #'unparse-alien-record-field (alien-record-type-fields type))))) +(defun unparse-alien-record-kind (kind) + (case kind + (:struct 'struct) + (:union 'union) + (t '???))) + +(defun unparse-alien-record-field (field) + `(,(alien-record-field-name field) + ,(%unparse-alien-type (alien-record-field-type field)) + ,@(when (alien-record-field-bits field) + (list :bits (alien-record-field-bits field))) + ,@(when (alien-record-field-offset field) + (list :offset (alien-record-field-offset field))))) + ;;; Test the record fields. Keep a hashtable table of already compared ;;; types to detect cycles. (defun record-fields-match-p (field1 field2) @@ -1045,27 +1139,68 @@ ;;;; the FUNCTION and VALUES alien types +;;; Calling-convention spec, typically one of predefined keywords. +;;; Add or remove as needed for target platform. It makes sense to +;;; support :cdecl everywhere. +;;; +;;; Null convention is supposed to be platform-specific most-universal +;;; callout convention. For x86, SBCL calls foreign functions in a way +;;; allowing them to be either stdcall or cdecl; null convention is +;;; appropriate here, as it is for specifying callbacks that could be +;;; accepted by foreign code both in cdecl and stdcall form. +(def!type calling-convention () `(or null (member :stdcall :cdecl))) + +;;; Convention could be a values type class, stored at result-type. +;;; However, it seems appropriate only for epilogue-related +;;; conventions, those not influencing incoming arg passing. +;;; +;;; As of x86's :stdcall and :cdecl, supported by now, both are +;;; epilogue-related, but future extensions (like :fastcall and +;;; miscellaneous non-x86 stuff) might affect incoming argument +;;; translation as well. + (define-alien-type-class (fun :include mem-block) (result-type (missing-arg) :type alien-type) (arg-types (missing-arg) :type list) - (stub nil :type (or null function))) + (stub nil :type (or null function)) + (convention nil :type calling-convention)) + +;;; KLUDGE: non-intrusive, backward-compatible way to allow calling +;;; convention specification for function types is unobvious. +;;; +;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list +;;; starting with a convention keyword; its second item is a real +;;; result-type in this case. If convention is ever to become a part +;;; of result-type, such a syntax can be retained. (define-alien-type-translator function (result-type &rest arg-types &environment env) - (make-alien-fun-type - :result-type (let ((*values-type-okay* t)) - (parse-alien-type result-type env)) - :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env)) - arg-types))) + (multiple-value-bind (bare-result-type calling-convention) + (typecase result-type + ((cons calling-convention *) + (values (second result-type) (first result-type))) + (t result-type)) + (make-alien-fun-type + :convention calling-convention + :result-type (let ((*values-type-okay* t)) + (parse-alien-type bare-result-type env)) + :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env)) + arg-types)))) (define-alien-type-method (fun :unparse) (type) - `(function ,(%unparse-alien-type (alien-fun-type-result-type type)) + `(function ,(let ((result-type + (%unparse-alien-type (alien-fun-type-result-type type))) + (convention (alien-fun-type-convention type))) + (if convention (list convention result-type) + result-type)) ,@(mapcar #'%unparse-alien-type (alien-fun-type-arg-types type)))) (define-alien-type-method (fun :type=) (type1 type2) (and (alien-type-= (alien-fun-type-result-type type1) (alien-fun-type-result-type type2)) + (eq (alien-fun-type-convention type1) + (alien-fun-type-convention type2)) (= (length (alien-fun-type-arg-types type1)) (length (alien-fun-type-arg-types type2))) (every #'alien-type-= @@ -1125,7 +1260,7 @@ #!+sb-doc "Return an Alien pointer to the data addressed by Expr, which must be a call to SLOT or DEREF, or a reference to an Alien variable." - (let ((form (sb!xc:macroexpand expr env))) + (let ((form (%macroexpand expr env))) (or (typecase form (cons (case (car form)