Changeset 5798
- Timestamp:
- Jan 28, 2007, 2:20:44 AM (18 years ago)
- File:
-
- 1 edited
-
trunk/ccl/compiler/PPC/PPC32/ppc32-backend.lisp (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/compiler/PPC/PPC32/ppc32-backend.lisp
r5788 r5798 28 28 (let* ((stack-word (gensym)) 29 29 (stack-ptr (gensym)) 30 (arg-names ()) 31 (arg-types ()) 32 (return-type :void) 30 (result-type-spec :void) 33 31 (args args) 34 32 (woi nil) 35 33 (monitor nil) 36 (dynamic-extent-names ()) 34 (need-struct-arg) 35 (struct-return-arg-name) 37 36 (error-return nil)) 37 (collect ((arg-names) 38 (arg-specs)) 39 (let* ((spec (car (last args))) 40 (rtype (ignore-errors (parse-foreign-type spec)))) 41 (setq need-struct-arg (typep rtype 'foreign-record-type)) 42 (if rtype 43 (setq result-type-spec spec args (butlast args)))) 44 38 45 (loop 39 46 (when (null args) (return)) 40 (when (null (cdr args))41 (setq return-type (car args))42 (return))43 47 (if (eq (car args) :without-interrupts) 44 48 (setq woi (cadr args) args (cddr args)) … … 50 54 :error-return) 51 55 args (cddr args)) 56 (if need-struct-arg 57 (setq struct-return-arg-name (pop args) need-struct-arg nil) 52 58 (progn 53 (push (foreign-type-to-representation-type (pop args)) arg-types) 54 (push (pop args) arg-names)))))) 55 (setq arg-names (nreverse arg-names) 56 arg-types (nreverse arg-types)) 57 (setq return-type (foreign-type-to-representation-type return-type)) 58 (when (eq return-type :void) 59 (setq return-type nil)) 60 (let* ((offset 96) 61 (gpr 0) 62 (fpr 32) 63 (need-stack-pointer (or arg-names return-type error-return)) 64 (lets 65 (mapcar 66 #'(lambda (name type) 67 (let* ((nextgpr gpr) 68 (nextfpr fpr) 69 (nextoffset offset) 70 (target gpr) 71 (bias 0)) 72 (prog1 73 (list name 74 `(, 75 (case type 76 (:single-float 77 (incf nextfpr 8) 78 (if (< fpr 96) 79 (setq target fpr) 80 (setq target (+ offset (logand offset 4)) 81 nextoffset (+ target 8))) 82 '%get-single-float-from-double-ptr) 83 (:double-float 84 (incf nextfpr 8) 85 (if (< fpr 96) 86 (setq target fpr) 87 (setq target (+ offset (logand offset 4)) 88 nextoffset (+ target 8))) 89 '%get-double-float) 90 (:signed-doubleword 91 (if (< gpr 56) 92 (setq target (+ gpr (logand gpr 4)) 93 nextgpr (+ 8 target)) 94 (setq target (+ offset (logand offset 4)) 95 nextoffset (+ 8 offset))) 96 '%%get-signed-longlong) 97 (:unsigned-doubleword 98 (if (< gpr 56) 99 (setq target (+ gpr (logand gpr 4)) 100 nextgpr (+ 8 target)) 101 (setq target (+ offset (logand offset 4)) 102 nextoffset (+ 8 offset))) 103 '%%get-unsigned-longlong) 104 (t 105 (incf nextgpr 4) 106 (if (< gpr 64) 107 (setq target gpr) 108 (setq target offset nextoffset (+ offset 4))) 109 (ecase type 110 (:signed-fullword '%get-signed-long) 111 (:signed-halfword (setq bias 2) '%get-signed-word) 112 (:signed-byte (setq bias 3) '%get-signed-byte) 113 (:unsigned-fullword '%get-unsigned-long) 114 (:unsigned-halfword (setq bias 2) '%get-unsigned-word) 115 (:unsigned-byte (setq bias 3) '%get-unsigned-byte) 116 (:address '%get-ptr)))) 117 ,stack-ptr 118 (+ ,target ,bias))) 119 (when (eq type :address) 120 (push name dynamic-extent-names)) 121 (setq gpr nextgpr fpr nextfpr offset nextoffset)))) 122 arg-names arg-types))) 123 (multiple-value-bind (body decls doc) (parse-body body env t) 124 `(progn 125 (declaim (special ,name)) 126 (define-callback-function 127 (nfunction ,name 128 (lambda (,stack-word) 129 (declare (ignorable ,stack-word)) 130 (block ,name 131 (with-macptrs (,@(and need-stack-pointer (list `(,stack-ptr)))) 132 ,(when need-stack-pointer 133 `(%setf-macptr-to-object ,stack-ptr ,stack-word)) 134 ,(defcallback-body stack-ptr lets dynamic-extent-names 135 decls body return-type error-return 136 0 137 ))))) 138 ,doc 139 ,woi 140 ,monitor)))))) 59 (arg-specs (pop args)) 60 (arg-names (pop args)))))))) 61 (multiple-value-bind (rlets lets dynamic-extent-names inits foreign-return-type) 62 (funcall (ftd-callback-bindings-function *target-ftd*) 63 stack-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name) 64 (multiple-value-bind (body decls doc) (parse-body body env t) 65 `(progn 66 (declaim (special ,name)) 67 (define-callback-function 68 (nfunction ,name 69 (lambda (,stack-word) 70 (declare (ignorable ,stack-word)) 71 (block ,name 72 (with-macptrs ((,stack-ptr)) 73 (%setf-macptr-to-object ,stack-ptr ,stack-word) 74 ,(defcallback-body stack-ptr 75 lets 76 rlets 77 inits 78 `(declare (dynamic-extent ,@dynamic-extent-names)) 79 decls 80 body 81 foreign-return-type 82 struct-return-arg-name 83 error-return 84 0 85 ))))) 86 ,doc 87 ,woi 88 ,monitor))))))) 141 89 142 90 #+eabi-target 143 (defun defcallback-body-ppc32-eabi (stack-ptr lets dynamic-extent-names decls body return-typeerror-return error-delta)91 (defun defcallback-body-ppc32-eabi (stack-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) 144 92 (let* ((result (gensym)) 145 (offset (case return-type146 ((:single-float :double-float)147 8)148 (t 0)))149 93 (condition-name (if (atom error-return) 'error (car error-return))) 150 94 (error-return-function (if (atom error-return) error-return (cadr error-return))) 151 95 (body 152 `( progn96 `(rlet ,rlets 153 97 (let ,lets 154 (declare (dynamic-extent ,@dynamic-extent-names))155 ,@ decls156 98 ,dynamic-extent-decls 99 ,@other-decls 100 ,@inits 157 101 (let ((,result (progn ,@body))) 158 102 (declare (ignorable ,result)) 159 103 ,@(progn 160 104 ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT 161 (when ( eq return-type :single-float)105 (when (typep return-type 'foreign-single-float-type) 162 106 (setq result `(float ,result 0.0d0))) 163 107 nil) 164 165 ,(when return-type 166 `(setf (, 167 (case return-type 168 (:address '%get-ptr) 169 (:signed-doubleword '%%get-signed-longlong) 170 (:unsigned-doubleword '%%get-unsigned-longlong) 171 ((:double-float :single-float) '%get-double-float) 172 (t '%get-long)) ,stack-ptr ,offset) ,result))))))) 108 ,(funcall (ftd-callback-return-value-function *target-ftd*) 109 stack-ptr 110 result 111 return-type 112 struct-return-arg)))))) 173 113 (if error-return 174 114 (let* ((cond (gensym)))
Note:
See TracChangeset
for help on using the changeset viewer.
