X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=92c529c49496531361c0b22c04c46ac4cb453561;hb=5d5894082c39ca44da75d38859d669c7b2108f6a;hp=56e743dd09b952f29f3e4c2917a9849e146c4018;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 56e743d..92c529c 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -22,7 +22,7 @@ (defun guess-alignment (bits) (cond ((null bits) nil) - #!-(or x86 (and ppc darwin)) ((> bits 32) 64) + #!-(or (and x86 (not win32)) (and ppc darwin)) ((> bits 32) 64) ((> bits 16) 32) ((> bits 8) 16) ((> bits 1) 8) @@ -43,6 +43,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)) @@ -73,6 +75,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))) @@ -281,9 +285,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) @@ -445,6 +446,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,20 +459,39 @@ (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 x86/x86-64, since on non-conservative + ;; gcs it'd imply disabling the GC. Which is something we + ;; don't want to do every time we're calling to C. + #!+(or x86 x86-64) + (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) (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)) @@ -502,6 +527,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)) @@ -656,7 +691,7 @@ (unless (and max (> max val)) (setq max val)) (unless (and min (< min val)) (setq min val)) (when (rassoc val from-alist) - (error "The element value ~S is used more than once." val)) + (style-warn "The element value ~S is used more than once." val)) (when (assoc sym from-alist :test #'eq) (error "The enumeration element ~S is used more than once." sym)) (push (cons sym val) from-alist))) @@ -966,14 +1001,14 @@ (overall-alignment 1) (parsed-fields nil)) (dolist (field fields) - (destructuring-bind (var type &optional bits) field - (declare (ignore bits)) + (destructuring-bind (var type &key alignment) field (let* ((field-type (parse-alien-type type env)) (bits (alien-type-bits field-type)) - (alignment (alien-type-alignment field-type)) (parsed-field (make-alien-record-field :type field-type :name var))) + (unless alignment + (setf alignment (alien-type-alignment field-type))) (push parsed-field parsed-fields) (when (null bits) (error "unknown size: ~S" (unparse-alien-type field-type))) @@ -1045,15 +1080,6 @@ ;;;; the FUNCTION and VALUES alien types -;;; not documented in CMU CL:-( -;;; -;;; reverse engineering observations: -;;; * seems to be set when translating return values -;;; * seems to enable the translation of (VALUES), which is the -;;; Lisp idiom for C's return type "void" (which is likely -;;; why it's set when when translating return values) -(defvar *values-type-okay* nil) - (define-alien-type-class (fun :include mem-block) (result-type (missing-arg) :type alien-type) (arg-types (missing-arg) :type list)