Changeset 5801


Ignore:
Timestamp:
Jan 28, 2007, 8:44:27 PM (18 years ago)
Author:
Gary Byers
Message:

Lose the old eabi-callback stuff; linuxppc 32/64-bit callbacks now use
the new scheme.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/compiler/PPC/PPC32/ppc32-backend.lisp

    r5798 r5801  
    2424
    2525
    26 #+eabi-target
    27 (defun define-ppc32-eabi-callback (name args body env)
    28   (let* ((stack-word (gensym))
    29          (stack-ptr (gensym))
    30          (result-type-spec :void)
    31          (args args)
    32          (woi nil)
    33          (monitor nil)
    34          (need-struct-arg)
    35          (struct-return-arg-name)
    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      
    45     (loop
    46       (when (null args) (return))
    47       (if (eq (car args) :without-interrupts)
    48         (setq woi (cadr args) args (cddr args))
    49         (if (eq (car args) :monitor-exception-ports)
    50           (setq monitor (cadr args) args (cddr args))
    51           (if (eq (car args) :error-return)
    52             (setq error-return
    53                   (warn "~s not yet implemented on this platform"
    54                         :error-return)
    55                   args (cddr args))
    56             (if need-struct-arg
    57               (setq struct-return-arg-name (pop args) need-struct-arg nil)
    58             (progn
    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)))))))
    89 
    90 #+eabi-target
    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)
    92   (let* ((result (gensym))
    93          (condition-name (if (atom error-return) 'error (car error-return)))
    94          (error-return-function (if (atom error-return) error-return (cadr error-return)))
    95          (body
    96           `(rlet ,rlets
    97             (let ,lets
    98               ,dynamic-extent-decls
    99               ,@other-decls
    100               ,@inits
    101               (let ((,result (progn ,@body)))
    102                 (declare (ignorable ,result))
    103                 ,@(progn
    104                    ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT
    105                    (when (typep return-type 'foreign-single-float-type)
    106                      (setq result `(float ,result 0.0d0)))
    107                    nil)
    108                 ,(funcall (ftd-callback-return-value-function *target-ftd*)
    109                           stack-ptr
    110                           result
    111                           return-type
    112                           struct-return-arg))))))
    113     (if error-return
    114       (let* ((cond (gensym)))
    115         `(handler-case ,body
    116           (,condition-name (,cond) (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)))))
    117       body)))
     26
    11827
    11928#+poweropen-target
Note: See TracChangeset for help on using the changeset viewer.