Changeset 11550
- Timestamp:
- Dec 24, 2008, 8:12:40 AM (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/compiler/X86/X8632/x8632-backend.lisp
r11326 r11550 285 285 (pushnew *x8632-backend* *known-backends* :key #'backend-name) 286 286 287 ;;; FFI stuff. Shared by several backends (Darwin notably excepted.) 288 289 ;;; A returned structure is always passed as a "hidden" first argument. 290 (defun x8632::record-type-returns-structure-as-first-arg (rtype) 291 (declare (ignore rtype)) 292 t) 293 294 ;;; All arguments are passed on the stack. 295 ;;; 296 ;;; (We don't support the __m64, __m128, __m128d, and __m128i types.) 297 298 (defun x8632::expand-ff-call (callform args 299 &key (arg-coerce #'null-coerce-foreign-arg) 300 (result-coerce #'null-coerce-foreign-result)) 301 (let* ((result-type-spec (or (car (last args)) :void)) 302 (result-form nil)) 303 (multiple-value-bind (result-type error) 304 (ignore-errors (parse-foreign-type result-type-spec)) 305 (if error 306 (setq result-type-spec :void result-type *void-foreign-type*) 307 (setq args (butlast args))) 308 (collect ((argforms)) 309 (when (typep result-type 'foreign-record-type) 310 (setq result-form (pop args) 311 result-type *void-foreign-type* 312 result-type-spec :void) 313 (argforms :address) 314 (argforms result-form)) 315 (unless (evenp (length args)) 316 (error "~s should be an even-length list of alternating foreign types and values" args)) 317 (do* ((args args (cddr args))) 318 ((null args)) 319 (let* ((arg-type-spec (car args)) 320 (arg-value-form (cadr args))) 321 (if (or (member arg-type-spec *foreign-representation-type-keywords* 322 :test #'eq) 323 (typep arg-type-spec 'unsigned-byte)) 324 (progn 325 (argforms arg-type-spec) 326 (argforms arg-value-form)) 327 (let* ((ftype (parse-foreign-type arg-type-spec)) 328 (bits (ensure-foreign-type-bits ftype))) 329 (when (and (typep ftype 'foreign-record-type) 330 (eq (foreign-record-type-kind ftype) 331 :transparent-union)) 332 (ensure-foreign-type-bits ftype) 333 (setq ftype (foreign-record-field-type 334 (car (foreign-record-type-fields ftype))) 335 arg-type-spec (foreign-type-to-representation-type 336 ftype) 337 bits (ensure-foreign-type-bits ftype))) 338 (if (typep ftype 'foreign-record-type) 339 (argforms (ceiling bits 32)) 340 (argforms (foreign-type-to-representation-type ftype))) 341 (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))) 342 (argforms (foreign-type-to-representation-type result-type)) 343 (funcall result-coerce result-type-spec 344 `(,@callform ,@(argforms))))))) 345 346 347 ;;; Return 7 values: 348 ;;; A list of RLET bindings 349 ;;; A list of LET* bindings 350 ;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings 351 ;;; A list of initializaton forms for (some) structure args (not used on x8632) 352 ;;; A FOREIGN-TYPE representing the "actual" return type. 353 ;;; A form which can be used to initialize FP-ARGS-PTR, relative 354 ;;; to STACK-PTR. (This is unused on x8632.) 355 ;;; The byte offset of the foreign return address, relative to STACK-PTR 356 357 (defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars 358 argspecs result-spec 359 struct-result-name) 360 (declare (ignore fp-args-ptr)) 361 (collect ((lets) 362 (dynamic-extent-names)) 363 (let* ((rtype (parse-foreign-type result-spec))) 364 (when (typep rtype 'foreign-record-type) 365 (setq argvars (cons struct-result-name argvars) 366 argspecs (cons :address argspecs) 367 rtype *void-foreign-type*)) 368 (do* ((argvars argvars (cdr argvars)) 369 (argspecs argspecs (cdr argspecs)) 370 (offset 8)) 371 ((null argvars) 372 (values nil (lets) (dynamic-extent-names) nil rtype nil 4)) 373 (let* ((name (car argvars)) 374 (spec (car argspecs)) 375 (argtype (parse-foreign-type spec)) 376 (bits (require-foreign-type-bits argtype)) 377 (double nil)) 378 (if (typep argtype 'foreign-record-type) 379 (lets (list name 380 `(%inc-ptr ,stack-ptr 381 ,(prog1 offset 382 (incf offset 383 (* 4 (ceiling bits 32))))))) 384 (progn 385 (lets (list name 386 `(, 387 (ecase (foreign-type-to-representation-type argtype) 388 (:single-float '%get-single-float) 389 (:double-float (setq double t) '%get-double-float) 390 (:signed-doubleword (setq double t) 391 '%%get-signed-longlong) 392 (:signed-fullword '%get-signed-long) 393 (:signed-halfword '%get-signed-word) 394 (:signed-byte '%get-signed-byte) 395 (:unsigned-doubleword (setq double t) 396 '%%get-unsigned-longlong) 397 (:unsigned-fullword '%get-unsigned-long) 398 (:unsigned-halfword '%get-unsigned-word) 399 (:unsigned-byte '%get-unsigned-byte) 400 (:address '%get-ptr)) 401 ,stack-ptr 402 ,offset))) 403 (incf offset 4) 404 (when double (incf offset 4))))))))) 405 406 (defun x8632::generate-callback-return-value (stack-ptr fp-args-ptr result 407 return-type struct-return-arg) 408 (declare (ignore fp-args-ptr struct-return-arg)) 409 (unless (eq return-type *void-foreign-type*) 410 (let* ((return-type-keyword (foreign-type-to-representation-type 411 return-type))) 412 (collect ((forms)) 413 (forms 'progn) 414 (case return-type-keyword 415 (:single-float 416 (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1))) 417 (:double-float 418 (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2)))) 419 (forms 420 `(setf (, 421 (case return-type-keyword 422 (:address '%get-ptr) 423 (:signed-doubleword '%%get-signed-longlong) 424 (:unsigned-doubleword '%%get-unsigned-longlong) 425 (:double-float '%get-double-float) 426 (:single-float '%get-single-float) 427 (:unsigned-fullword '%get-unsigned-long) 428 (t '%get-signed-long) 429 ) ,stack-ptr -8) ,result)) 430 (forms))))) 431 432 433 287 434 #+x8632-target 288 435 (require "X8632-VINSNS")
Note: See TracChangeset
for help on using the changeset viewer.