Changeset 11549
- Timestamp:
- Dec 24, 2008, 7:35:26 AM (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/lib/ffi-linuxx8632.lisp
r10790 r11549 1 1 (in-package "CCL") 2 2 3 ;;; Some small structures are returned in EAX and EDX. Otherwise, 4 ;;; return values are placed at the address specified by the caller. 3 ;; Always use the "hidden first arg" convention on linuxx8632 5 4 (defun x86-linux32::record-type-returns-structure-as-first-arg (rtype) 6 (when (and rtype 7 (not (typep rtype 'unsigned-byte)) 8 (not (member rtype *foreign-representation-type-keywords* 9 :test #'eq))) 10 (let* ((ftype (if (typep rtype 'foreign-type) 11 rtype 12 (parse-foreign-type rtype))) 13 (nbits (ensure-foreign-type-bits ftype))) 14 (not (member nbits '(8 16 32 64)))))) 15 16 (defun x86-linux32::struct-from-regbuf-values (r rtype regbuf) 17 (ecase (ensure-foreign-type-bits rtype) 18 (8 `(setf (%get-unsigned-byte ,r 0) (%get-unsigned-byte ,regbuf 0))) 19 (16 `(setf (%get-unsigned-word ,r 0) (%get-unsigned-word ,regbuf 0))) 20 (32 `(setf (%get-unsigned-long ,r 0) (%get-unsigned-long ,regbuf 0))) 21 (64 `(setf (%%get-unsigned-longlong ,r 0) 22 (%%get-unsigned-longlong ,regbuf 0))))) 5 (declare (ignore rtype)) 6 t) 23 7 24 8 ;;; All arguments are passed on the stack. … … 28 12 (defun x86-linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) 29 13 (let* ((result-type-spec (or (car (last args)) :void)) 30 (regbuf nil) 31 (result-temp nil) 32 (result-form nil) 33 (struct-result-type nil)) 14 (result-form nil)) 34 15 (multiple-value-bind (result-type error) 35 16 (ignore-errors (parse-foreign-type result-type-spec)) … … 38 19 (setq args (butlast args))) 39 20 (collect ((argforms)) 40 (when (eq (car args) :monitor-exception-ports)41 (argforms (pop args)))42 21 (when (typep result-type 'foreign-record-type) 43 22 (setq result-form (pop args) 44 struct-result-type result-type45 23 result-type *void-foreign-type* 46 24 result-type-spec :void) 47 (if (x86-linux32::record-type-returns-structure-as-first-arg result-type) 48 (progn 49 (argforms :address) 50 (argforms result-form)) 51 (progn 52 (setq regbuf (gensym) 53 result-temp (gensym)) 54 (argforms :registers) 55 (argforms regbuf)))) 25 (argforms :address) 26 (argforms result-form)) 56 27 (unless (evenp (length args)) 57 28 (error "~s should be an even-length list of alternating foreign types and values" args)) … … 75 46 arg-type-spec (foreign-type-to-representation-type ftype) 76 47 bits (ensure-foreign-type-bits ftype))) 77 (if (and (typep ftype 'foreign-record-type) 78 (<= bits 32)) 48 (if (typep ftype 'foreign-record-type) 79 49 (argforms (ceiling bits 32)) 80 50 (argforms (foreign-type-to-representation-type ftype))) … … 82 52 (argforms (foreign-type-to-representation-type result-type)) 83 53 (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) 84 (if regbuf 85 `(let* ((,result-temp (%null-ptr))) 86 (declare (dynamic-extent ,result-temp) 87 (type macptr ,result-temp)) 88 (%setf-macptr ,result-temp ,result-form) 89 (%stack-block ((,regbuf 8)) 90 ,call 91 ,(x86-linux32::struct-from-regbuf-values result-temp struct-result-type regbuf))) 92 call)))))) 54 call))))) 93 55 94 56 ;;; Return 7 values: … … 96 58 ;;; A list of LET* bindings 97 59 ;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings 98 ;;; A list of initializaton forms for (some) structure args 60 ;;; A list of initializaton forms for (some) structure args (not used on x8632) 99 61 ;;; A FOREIGN-TYPE representing the "actual" return type. 100 62 ;;; A form which can be used to initialize FP-ARGS-PTR, relative … … 106 68 (collect ((lets) 107 69 (rlets) 108 (inits)109 70 (dynamic-extent-names)) 110 71 (let* ((rtype (parse-foreign-type result-spec))) … … 117 78 (do* ((argvars argvars (cdr argvars)) 118 79 (argspecs argspecs (cdr argspecs)) 119 (offset 8 (incf offset 4)))80 (offset 8)) 120 81 ((null argvars) 121 (values (rlets) (lets) (dynamic-extent-names) (inits)rtype nil 4))82 (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4)) 122 83 (let* ((name (car argvars)) 123 84 (spec (car argspecs)) … … 126 87 (double nil)) 127 88 (if (typep argtype 'foreign-record-type) 89 (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 offset 90 (incf offset (* 4 (ceiling bits 32))))))) 128 91 (progn 129 ( format t "~& arg is some foreign type"))130 (lets (list name131 `(,132 (ecase (foreign-type-to-representation-type argtype)133 (:single-float '%get-single-float)134 (:double-float (setq double t) '%get-double-float)135 (:signed-doubleword (setq double t)136 '%%get-signed-longlong)137 (:signed-fullword '%get-signed-long)138 (:signed-halfword '%get-signed-word)139 (:signed-byte '%get-signed-byte)140 (:unsigned-doubleword (setq double t)141 '%%get-unsigned-longlong)142 (:unsigned-fullword '%get-unsigned-long)143 (:unsigned-halfword '%get-unsigned-word)144 (:unsigned-byte '%get-unsigned-byte)145 (:address '%get-ptr))146 ,stack-ptr147 ,offset))))148 (when double (incf offset 4)))))))92 (lets (list name 93 `(, 94 (ecase (foreign-type-to-representation-type argtype) 95 (:single-float '%get-single-float) 96 (:double-float (setq double t) '%get-double-float) 97 (:signed-doubleword (setq double t) 98 '%%get-signed-longlong) 99 (:signed-fullword '%get-signed-long) 100 (:signed-halfword '%get-signed-word) 101 (:signed-byte '%get-signed-byte) 102 (:unsigned-doubleword (setq double t) 103 '%%get-unsigned-longlong) 104 (:unsigned-fullword '%get-unsigned-long) 105 (:unsigned-halfword '%get-unsigned-word) 106 (:unsigned-byte '%get-unsigned-byte) 107 (:address '%get-ptr)) 108 ,stack-ptr 109 ,offset))) 110 (incf offset 4) 111 (when double (incf offset 4))))))))) 149 112 150 113 (defun x86-linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) 151 (declare (ignore fp-args-ptr)) 152 (format t "~&in generate-callback-return-value") 114 (declare (ignore fp-args-ptr struct-return-arg)) 153 115 (unless (eq return-type *void-foreign-type*) 154 116 (if (typep return-type 'foreign-record-type) 155 ;; Would have been mapped to :VOID unless record-type was <= 64 bits156 ( format t "~&need to return structure ~s by value" return-type)117 ;; Should have been mapped to :VOID 118 (error "Shouldn't be trying to return a structure by value on linuxx8632") 157 119 (let* ((return-type-keyword (foreign-type-to-representation-type return-type))) 158 (c cl::collect ((forms))120 (collect ((forms)) 159 121 (forms 'progn) 160 122 (case return-type-keyword
Note: See TracChangeset
for help on using the changeset viewer.