X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=29bb28f2f330a634c04f64081ed56865eb7faba3;hb=8eee0d3a30bf39d9f201acff28c92059fe6c3e4e;hp=3466981a98792a525de2847471e30775a73e3a11;hpb=09120f07344932375511dd6239ea809a6e444554;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 3466981..29bb28f 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) - (warn "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))) @@ -927,41 +962,45 @@ ;;; 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)) @@ -980,34 +1019,37 @@ (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))) (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 (alien-record-field-bits field))))) + ;;; Test the record fields. Keep a hashtable table of already compared ;;; types to detect cycles. (defun record-fields-match-p (field1 field2) @@ -1045,15 +1087,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)