Changeset 5807


Ignore:
Timestamp:
Jan 29, 2007, 11:36:01 AM (14 years ago)
Author:
gb
Message:

No more (old) callback stuff here.

File:
1 edited

Legend:

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

    r5801 r5807  
    2626
    2727
    28 #+poweropen-target
    29 (defun define-ppc32-poweropen-callback (name args body env)
    30   (let* ((stack-word (gensym))
    31          (stack-ptr (gensym))
    32          (fp-arg-regs (gensym))
    33          (fp-arg-num 0)
    34          (arg-names ())
    35          (arg-types ())
    36          (return-type :void)
    37          (args args)
    38          (woi nil)
    39          (monitor nil)
    40          (dynamic-extent-names ())
    41          (error-return nil))
    42     (loop
    43       (when (null args) (return))
    44       (when (null (cdr args))
    45         (setq return-type (car args))
    46         (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                   (cadr args)
    54                   args (cddr args))
    55             (progn
    56               (push (foreign-type-to-representation-type (pop args)) arg-types)
    57               (push (pop args) arg-names))))))
    58     (setq arg-names (nreverse arg-names)
    59           arg-types (nreverse arg-types))
    60     (setq return-type (foreign-type-to-representation-type return-type))
    61     (when (eq return-type :void)
    62       (setq return-type nil))
    63     (let* ((offset 0)
    64            (need-stack-pointer (or arg-names return-type error-return))
    65            (lets
    66              (mapcar
    67               #'(lambda (name type)
    68                   (let* ((delta 4)
    69                          (bias 0)
    70                          (use-fp-args nil))
    71                     (prog1
    72                         (list name
    73                               `(,
    74                                 (if (typep type 'unsigned-byte)
    75                                   (progn (setq delta (* 4 type)) '%inc-ptr)
    76                                   (ecase type
    77                                     (:single-float
    78                                      (if (< (incf fp-arg-num) 14)
    79                                        (progn
    80                                          (setq use-fp-args t)
    81                                          '%get-single-float-from-double-ptr)
    82                                        '%get-single-float))
    83                                     (:double-float
    84                                      (setq delta 8)
    85                                      (if (< (incf fp-arg-num) 14)
    86                                        (setq use-fp-args t))
    87                                      '%get-double-float)
    88                                     (:signed-doubleword (setq delta 8) '%%get-signed-longlong)
    89                                     (:signed-fullword
    90                                      (setq bias 0)
    91                                      '%get-signed-long)
    92                                     (:signed-halfword (setq bias 2)
    93                                                       '%get-signed-word)
    94                                     (:signed-byte (setq bias 3)
    95                                                   '%get-signed-byte)
    96                                     (:unsigned-doubleword (setq delta 8) '%%get-unsigned-longlong)
    97                                     (:unsigned-fullword
    98                                      (setq bias 0)
    99                                      '%get-unsigned-long)
    100                                     (:unsigned-halfword
    101                                      (setq bias 2)
    102                                      '%get-unsigned-word)
    103                                     (:unsigned-byte
    104                                      (setq bias 3)
    105                                      '%get-unsigned-byte)
    106                                     (:address '%get-ptr)))
    107                                 ,(if use-fp-args fp-arg-regs stack-ptr)
    108                                 ,(if use-fp-args (* 8 (1- fp-arg-num))
    109                                      `(+ ,offset ,bias))))
    110                       (when (or (eq type :address)
    111                                 (typep type 'unsigned-byte))
    112                         (push name dynamic-extent-names))
    113                       (incf offset delta))))
    114               arg-names arg-types)))
    115       (multiple-value-bind (body decls doc) (parse-body body env t)
    116         `(progn
    117            (declaim (special ,name))
    118            (define-callback-function
    119              (nfunction ,name
    120                         (lambda (,stack-word)
    121                           (declare (ignorable ,stack-word))
    122                           (block ,name
    123                             (with-macptrs (,@(and need-stack-pointer (list `(,stack-ptr))))
    124                               ,(when need-stack-pointer
    125                                  `(%setf-macptr-to-object ,stack-ptr ,stack-word))
    126                               ,(defcallback-body  stack-ptr lets dynamic-extent-names
    127                                                  decls body return-type error-return
    128                                                  (- ppc32::c-frame.savelr ppc32::c-frame.param0)
    129                                                  fp-arg-regs
    130                                                  )))))
    131              ,doc
    132              ,woi
    133              ,monitor))))))
    134 
    135 #+poweropen-target
    136 (defun defcallback-body-ppc32-poweropen (stack-ptr lets dynamic-extent-names decls body return-type error-return error-delta #+poweropen-target fp-arg-ptr)
    137   (let* ((result (gensym))
    138          (return-ptr (case return-type
    139                        ((:single-float :double-float)
    140                         fp-arg-ptr)
    141                        (t stack-ptr)))
    142          (condition-name (if (atom error-return) 'error (car error-return)))
    143          (error-return-function (if (atom error-return) error-return (cadr error-return)))
    144          (body
    145           `(with-macptrs ((,fp-arg-ptr))
    146             (%setf-macptr ,fp-arg-ptr (%get-ptr ,stack-ptr (- ppc32::c-frame.unused-1 ppc32::c-frame.param0)))
    147             (let ,lets
    148               (declare (dynamic-extent ,@dynamic-extent-names))
    149               ,@decls
    150 
    151               (let ((,result (progn ,@body)))
    152                 (declare (ignorable ,result))
    153                 ,@(progn
    154                    ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT
    155                    (when (eq return-type :single-float)
    156                      (setq result `(float ,result 0.0d0)))
    157                    nil)
    158 
    159                 ,(when return-type
    160                        `(setf (,
    161                                (case return-type
    162                                  (:address '%get-ptr)
    163                                  (:signed-doubleword '%%get-signed-longlong)
    164                                  (:unsigned-doubleword '%%get-unsigned-longlong)
    165                                  ((:double-float :single-float) '%get-double-float)
    166                                  (t  '%get-long)) ,return-ptr 0) ,result)))))))
    167     (if error-return
    168       (let* ((cond (gensym)))
    169         `(handler-case ,body
    170           (,condition-name (,cond) (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)))))
    171       body)))
    17228
    17329(defvar *ppc32-vinsn-templates* (make-hash-table :test #'eq))
     
    20056                :target-arch-name :ppc32
    20157                :target-foreign-type-data nil
    202                 :target-arch ppc32::*ppc32-target-arch*
    203                 :define-callback 'define-ppc32-eabi-callback
    204                 :defcallback-body 'defcallback-body-ppc32-eabi))
     58                :target-arch ppc32::*ppc32-target-arch*))
    20559
    20660
     
    22680                :target-arch-name :ppc32
    22781                :target-foreign-type-data nil
    228                 :target-arch ppc32::*ppc32-target-arch*
    229                 :define-callback 'define-ppc32-poweropen-callback
    230                 :defcallback-body 'defcallback-body-ppc32-poweropen))
     82                :target-arch ppc32::*ppc32-target-arch*))
    23183
    23284#+linuxppc-target
Note: See TracChangeset for help on using the changeset viewer.