Changeset 12694
- Timestamp:
- Aug 26, 2009, 11:34:01 AM (15 years ago)
- Location:
- branches/working-0711/ccl
- Files:
-
- 10 edited
-
compiler/X86/X8632/x8632-backend.lisp (modified) (2 diffs)
-
compiler/X86/X8664/x8664-backend.lisp (modified) (2 diffs)
-
compiler/X86/x862.lisp (modified) (1 diff)
-
compiler/backend.lisp (modified) (1 diff)
-
lib/ffi-darwinppc32.lisp (modified) (1 diff)
-
lib/ffi-darwinppc64.lisp (modified) (2 diffs)
-
lib/ffi-linuxppc32.lisp (modified) (1 diff)
-
lib/ffi-linuxppc64.lisp (modified) (2 diffs)
-
lib/ffi-win64.lisp (modified) (2 diffs)
-
lib/macros.lisp (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/compiler/X86/X8632/x8632-backend.lisp
r12198 r12694 383 383 384 384 (defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars 385 386 385 argspecs result-spec 386 struct-result-name) 387 387 (declare (ignore fp-args-ptr)) 388 388 (collect ((lets) … … 409 409 (double nil)) 410 410 (if (typep argtype 'foreign-record-type) 411 (lets (list name 412 `(%inc-ptr ,stack-ptr 413 ,(prog1 offset 414 (incf offset 415 (* 4 (ceiling bits 32))))))) 416 (progn 417 (lets (list name 418 `(, 419 (ecase (foreign-type-to-representation-type argtype) 420 (:single-float '%get-single-float) 421 (:double-float (setq double t) '%get-double-float) 422 (:signed-doubleword (setq double t) 423 '%%get-signed-longlong) 424 (:signed-fullword '%get-signed-long) 425 (:signed-halfword '%get-signed-word) 426 (:signed-byte '%get-signed-byte) 427 (:unsigned-doubleword (setq double t) 428 '%%get-unsigned-longlong) 429 (:unsigned-fullword '%get-unsigned-long) 430 (:unsigned-halfword '%get-unsigned-word) 431 (:unsigned-byte '%get-unsigned-byte) 432 (:address '%get-ptr)) 433 ,stack-ptr 434 ,offset))) 411 (let* ((form `(%inc-ptr ,stack-ptr 412 ,(prog1 offset 413 (incf offset 414 (* 4 (ceiling bits 32))))))) 415 (when name (lets (list name form)))) 416 (let* ((form `(, 417 (ecase (foreign-type-to-representation-type argtype) 418 (:single-float '%get-single-float) 419 (:double-float (setq double t) '%get-double-float) 420 (:signed-doubleword (setq double t) 421 '%%get-signed-longlong) 422 (:signed-fullword '%get-signed-long) 423 (:signed-halfword '%get-signed-word) 424 (:signed-byte '%get-signed-byte) 425 (:unsigned-doubleword (setq double t) 426 '%%get-unsigned-longlong) 427 (:unsigned-fullword '%get-unsigned-long) 428 (:unsigned-halfword '%get-unsigned-word) 429 (:unsigned-byte '%get-unsigned-byte) 430 (:address '%get-ptr)) 431 ,stack-ptr 432 ,offset))) 433 (when name (lets (list name form))) 435 434 (incf offset 4) 436 435 (when double (incf offset 4))))))))) -
branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp
r11054 r12694 88 88 :target-arch x8664::*x8664-target-arch* 89 89 ;; Overload %gs until Apple straightens things out. 90 :lisp-context-register x8664::gs 90 ;; Whoops; they never did. 91 :lisp-context-register x8664::r11 91 92 )) 92 93 … … 590 591 (:float (if (< (decf fprs) 0) (setq first8 :memory))))) 591 592 (if (eq first8 :memory) 593 (let* ((form `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset 594 (incf memory-arg-offset (* 8 (ceiling bits 64))))))) 595 (when name 596 (lets (list name form)) 597 (dynamic-extent-names name))) 592 598 (progn 593 (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset 594 (incf memory-arg-offset (* 8 (ceiling bits 64))))))) 595 (dynamic-extent-names name)) 596 (progn 597 (rlets (list name (foreign-record-type-name argtype))) 598 (inits `(setf (%%get-unsigned-longlong ,name 0) 599 (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr))))) 599 (when name (rlets (list name (foreign-record-type-name argtype)))) 600 (let* ((init1 `(setf (%%get-unsigned-longlong ,name 0) 601 (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr)))))) 602 (when name (inits init1))) 600 603 (if second8 601 (inits `(setf (%%get-unsigned-longlong ,name 8) 602 (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr))))))))) 603 (lets (list name 604 `(, 605 (ecase (foreign-type-to-representation-type argtype) 606 (:single-float (setq fp t) '%get-single-float) 607 (:double-float (setq fp t) '%get-double-float) 608 (:signed-doubleword '%%get-signed-longlong) 609 (:signed-fullword '%get-signed-long) 610 (:signed-halfword '%get-signed-word) 611 (:signed-byte '%get-signed-byte) 612 (:unsigned-doubleword '%%get-unsigned-longlong) 613 (:unsigned-fullword '%get-unsigned-long) 614 (:unsigned-halfword '%get-unsigned-word) 615 (:unsigned-byte '%get-unsigned-byte) 616 (:address 617 #+nil 618 (dynamic-extent-names name) 619 '%get-ptr)) 620 ,stack-ptr 621 ,(if fp (next-fpr) (next-gpr)))))))))))) 604 (let* ((init2 `(setf (%%get-unsigned-longlong ,name 8) 605 (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr)))))) 606 (when name (inits init2 ))))))) 607 (let* ((form`(, 608 (ecase (foreign-type-to-representation-type argtype) 609 (:single-float (setq fp t) '%get-single-float) 610 (:double-float (setq fp t) '%get-double-float) 611 (:signed-doubleword '%%get-signed-longlong) 612 (:signed-fullword '%get-signed-long) 613 (:signed-halfword '%get-signed-word) 614 (:signed-byte '%get-signed-byte) 615 (:unsigned-doubleword '%%get-unsigned-longlong) 616 (:unsigned-fullword '%get-unsigned-long) 617 (:unsigned-halfword '%get-unsigned-word) 618 (:unsigned-byte '%get-unsigned-byte) 619 (:address 620 #+nil 621 (when name (dynamic-extent-names name)) 622 '%get-ptr)) 623 ,stack-ptr 624 ,(if fp (next-fpr) (next-gpr))))) 625 (if name (lets (list name form ))))))))))) 622 626 623 627 (defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) -
branches/working-0711/ccl/compiler/X86/x862.lisp
r12363 r12694 8297 8297 8298 8298 (defx862 x862-flet flet (seg vreg xfer vars afuncs body p2decls) 8299 (x862-seq-fbind seg vreg xfer vars afuncs body p2decls)) 8299 (if (dolist (afunc afuncs) 8300 (unless (eql 0 (afunc-fn-refcount afunc)) 8301 (return t))) 8302 (x862-seq-fbind seg vreg xfer vars afuncs body p2decls) 8303 (with-x86-p2-declarations p2decls 8304 (x862-form seg vreg xfer body)))) 8300 8305 8301 8306 (defx862 x862-labels labels (seg vreg xfer vars afuncs body p2decls) -
branches/working-0711/ccl/compiler/backend.lisp
r12048 r12694 222 222 (return (make-hard-crf-reg (the fixnum (ash bit 2))))))) 223 223 224 (defun single-float-reg-p (reg) 225 (and (= (hard-regspec-class reg) hard-reg-class-fpr) 226 (= (get-regspec-mode reg) hard-reg-class-fpr-mode-single))) 227 224 228 (defun use-fp-temp (n) 225 229 (setq *available-backend-fp-temps* (logand *available-backend-fp-temps* (lognot (ash 1 n)))) -
branches/working-0711/ccl/lib/ffi-darwinppc32.lisp
r7376 r12694 211 211 (if type0 212 212 (progn 213 ( rlets (list name (foreign-record-type-name argtype)))214 ( inits`(setf ,(%foreign-access-form name type0 0 nil)213 (when name (rlets (list name (foreign-record-type-name argtype)))) 214 (let* ((init `(setf ,(%foreign-access-form name type0 0 nil) 215 215 ,(next-scalar-arg type0)))) 216 (progn (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4)) 217 (lets (list name `(%inc-ptr ,stack-ptr ,offset )))))) 218 (lets (list name (next-scalar-arg argtype)))) 216 (when name (inits init)))) 217 (progn 218 (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4)) 219 (when name ; no side-efects hers 220 (lets (list name `(%inc-ptr ,stack-ptr ,offset))))))) 221 (let* ((pair (list name (next-scalar-arg argtype)))) 222 (when name (lets pair)))) 219 223 #+nil 220 224 (when (or (typep argtype 'foreign-pointer-type) -
branches/working-0711/ccl/lib/ffi-darwinppc64.lisp
r12301 r12694 457 457 (= bits 128)) 458 458 (progn (setq delta (* (ceiling bits 64) 8)) 459 ( lets (list name `(%inc-ptr ,stack-ptr ,offset)))459 (when name (lets (list name `(%inc-ptr ,stack-ptr ,offset )))) 460 460 (incf offset delta)) 461 461 … … 477 477 'foreign-single-float-type)) 478 478 (return t)))))) 479 ( rlets (list name (or (foreign-record-type-name argtype)480 spec))) 479 (when name (rlets (list name (or (foreign-record-type-name argtype) 480 spec)))) 481 481 (do* ((bit-offset 0 (+ bit-offset 64)) 482 482 (byte-offset 0 (+ byte-offset 8))) 483 483 ((>= bit-offset bits)) 484 484 (if (double-float-at-offset bit-offset) 485 (inits `(setf (%get-double-float ,name ,byte-offset) 486 ,(next-scalar-arg (parse-foreign-type :double-float)))) 485 (let* ((init `(setf (%get-double-float ,name ,byte-offset) 486 ,(next-scalar-arg (parse-foreign-type :double-float))))) 487 (when name 488 (inits init))) 487 489 (let* ((high-single (single-float-at-offset bit-offset)) 488 (low-single (single-float-at-offset (+ bit-offset 32)))) 489 (inits `(setf (%%get-unsigned-longlong ,name ,byte-offset) 490 ,(next-scalar-arg (parse-foreign-type '(:unsigned 64))))) 490 (low-single (single-float-at-offset (+ bit-offset 32))) 491 (init `(setf (%%get-unsigned-longlong ,name ,byte-offset) 492 ,(next-scalar-arg (parse-foreign-type '(:unsigned 64)))))) 493 (when name (inits init)) 491 494 (when high-single 492 495 (when (< (incf fp-arg-num) 14) 493 496 (set-fp-regs-form) 494 (inits `(setf (%get-single-float ,name ,byte-offset) 497 (when name 498 (inits `(setf (%get-single-float ,name ,byte-offset) 495 499 (%get-single-float-from-double-ptr 496 500 ,fp-args-ptr 497 ,(* 8 (1- fp-arg-num))))))) 501 ,(* 8 (1- fp-arg-num)))))))) 498 502 (when low-single 499 503 (when (< (incf fp-arg-num) 14) 500 504 (set-fp-regs-form) 501 (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset)) 505 (when name 506 (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset)) 502 507 (%get-single-float-from-double-ptr 503 508 ,fp-args-ptr 504 ,(* 8 (1- fp-arg-num))))))))))))) 505 (lets (list name (next-scalar-arg argtype)))) 509 ,(* 8 (1- fp-arg-num)))))))))))))) 510 (let* ((pair (list name (next-scalar-arg argtype)))) 511 (when name 512 (lets name)))) 506 513 #+nil 507 514 (when (or (typep argtype 'foreign-pointer-type) -
branches/working-0711/ccl/lib/ffi-linuxppc32.lisp
r7376 r12694 187 187 ,stack-ptr 188 188 ,(+ target bias)))) 189 ( lets (list name access-form))189 (when name (lets (list name access-form))) 190 190 #+nil 191 191 (when (eq spec :address) -
branches/working-0711/ccl/lib/ffi-linuxppc64.lisp
r7135 r12694 111 111 (< bits 64)) 112 112 (progn 113 ( rlets (list name (foreign-record-type-name argtype)))114 ( inits `(setf (%%get-unsigned-longlong ,name 0)115 (ash (%%get-unsigned-longlong ,stack-ptr ,offset)116 ,(- 64 bits)))))113 (when name (rlets (list name (foreign-record-type-name argtype)))) 114 (when name (inits `(setf (%%get-unsigned-longlong ,name 0) 115 (ash (%%get-unsigned-longlong ,stack-ptr ,offset) 116 ,(- 64 bits)))))) 117 117 (let* ((access-form 118 118 `(,(cond … … 169 169 ,(if use-fp-args (* 8 (1- fp-arg-num)) 170 170 `(+ ,offset ,bias))))) 171 (lets (list name access-form)) 171 (when name (lets (list name access-form))) 172 #+nil 172 173 (when (eq spec :address) 173 174 (dynamic-extent-names name)) -
branches/working-0711/ccl/lib/ffi-win64.lisp
r11278 r12694 137 137 (if (typep argtype 'foreign-record-type) 138 138 (setq argtype :address)) 139 (let s (list name140 139 (let* ((access-form 140 `(, 141 141 (ecase (foreign-type-to-representation-type argtype) 142 142 (:single-float (setq fp t) '%get-single-float) … … 155 155 '%get-ptr)) 156 156 ,stack-ptr 157 ,(if fp (next-fpr) (next-gpr))))))))))) 157 ,(if fp (next-fpr) (next-gpr))))) 158 (when name (lets (list name access-form)))))))))) 158 159 159 160 (defun win64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) -
branches/working-0711/ccl/lib/macros.lisp
r12585 r12694 2653 2653 (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args 2654 2654 (declare (ignorable dynamic-extent-decls)) 2655 (let* ((result (gensym)) 2656 (condition-name (if (atom error-return) 'error (car error-return))) 2655 (let* ((condition-name (if (atom error-return) 'error (car error-return))) 2657 2656 (error-return-function (if (atom error-return) error-return (cadr error-return))) 2657 (result (if struct-return-arg (gensym))) 2658 2658 (body 2659 2659 `(rlet ,rlets … … 2662 2662 ,@other-decls 2663 2663 ,@inits 2664 (let ((,result (progn ,@body))) 2665 (declare (ignorable ,result) 2666 (dynamic-extent ,result)) 2667 2668 ,(funcall (ftd-callback-return-value-function *target-ftd*) 2669 stack-ptr 2670 fp-args-ptr 2671 result 2672 return-type 2673 struct-return-arg) 2674 nil))))) 2664 ,(if result 2665 `(let* ((,result ,@body)) 2666 (declare (dynamic-extent ,result) 2667 (ignorable ,result)) 2668 ,(funcall (ftd-callback-return-value-function *target-ftd*) 2669 stack-ptr 2670 fp-args-ptr 2671 result 2672 return-type 2673 struct-return-arg)) 2674 (if (eq return-type *void-foreign-type*) 2675 `(progn ,@body) 2676 (funcall (ftd-callback-return-value-function *target-ftd*) 2677 stack-ptr 2678 fp-args-ptr 2679 `(progn ,@body) 2680 return-type 2681 struct-return-arg))) 2682 nil)))) 2675 2683 (if error-return 2676 2684 (let* ((cond (gensym)) … … 2679 2687 `(block ,block 2680 2688 (let* ((,handler (lambda (,cond) 2681 2682 2683 2689 (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)) 2690 (return-from ,block 2691 nil)))) 2684 2692 (declare (dynamic-extent ,handler)) 2685 (handler-bind ((,condition-name ,handler))2686 (values ,body)))))2693 (handler-bind ((,condition-name ,handler)) 2694 (values ,body))))) 2687 2695 body)))) 2688 2696
Note:
See TracChangeset
for help on using the changeset viewer.
