Changeset 14548


Ignore:
Timestamp:
Jan 4, 2011, 1:22:00 AM (10 years ago)
Author:
gb
Message:

Don't try to share a single FFI interface file between LinuxARM
and AndroidARM (even though these systems use the same ABI.)
Move the actual implementation of these functions to arm-backend;
add a new ffi-androidarm file.

Location:
trunk/source
Files:
1 added
6 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/compiler/ARM/arm-backend.lisp

    r14543 r14548  
    347347                                         :struct-by-value t)
    348348                           :ff-call-expand-function
    349                            (intern "EXPAND-FF-CALL" "ARM-LINUX")
     349                           (intern "EXPAND-FF-CALL" "ARM-ANDROID")
    350350                           :ff-call-struct-return-by-implicit-arg-function
    351351                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
    352352                                   "ARM-LINUX")
    353353                           :callback-bindings-function
    354                            (intern "GENERATE-CALLBACK-BINDINGS" "ARM-LINUX")
     354                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-ANDROID")
    355355                           :callback-return-value-function
    356                            (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-LINUX"))))))
     356                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-ANDROID"))))))
    357357        (install-standard-foreign-types ftd)
    358358        (use-interface-dir :libc ftd)
    … …  
    370370  `(ccl::%istruct 'arm::fake-stack-frame ,sp ,next-sp ,fn ,lr ,vsp ,xp))
    371371
     372(defun arm::eabi-record-type-returns-structure-as-first-arg (rtype)
     373  (when (and rtype
     374             (not (typep rtype 'unsigned-byte))
     375             (not (member rtype *foreign-representation-type-keywords*
     376                          :test #'eq)))
     377    (let* ((ftype (if (typep rtype 'foreign-type)
     378                    rtype
     379                    (parse-foreign-type rtype))))
     380      (when (typep ftype 'foreign-record-type)
     381        (ensure-foreign-type-bits ftype)
     382        (> (foreign-type-bits ftype) 32)))))
     383
     384(defun arm::eabi-expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
     385  (let* ((result-type-spec (or (car (last args)) :void))
     386         (enclosing-form nil)
     387         (result-form nil))
     388    (multiple-value-bind (result-type error)
     389        (ignore-errors (parse-foreign-type result-type-spec))
     390      (if error
     391        (setq result-type-spec :void result-type *void-foreign-type*)
     392        (setq args (butlast args)))
     393      (collect ((argforms))
     394        (when (typep result-type 'foreign-record-type)
     395          (setq result-form (pop args))
     396          (if (arm-linux::record-type-returns-structure-as-first-arg result-type)
     397            (progn
     398              (setq result-type *void-foreign-type*
     399                    result-type-spec :void)
     400              (argforms :address)
     401              (argforms result-form))
     402            ;; This only happens in the SVR4 ABI.
     403            (progn
     404              (setq result-type (parse-foreign-type :unsigned-doubleword)
     405                    result-type-spec :unsigned-doubleword
     406                    enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0))))))
     407        (unless (evenp (length args))
     408          (error "~s should be an even-length list of alternating foreign types and values" args))       
     409        (do* ((args args (cddr args)))
     410             ((null args))
     411          (let* ((arg-type-spec (car args))
     412                 (arg-value-form (cadr args)))
     413            (if (or (member arg-type-spec *foreign-representation-type-keywords*
     414                           :test #'eq)
     415                    (typep arg-type-spec 'unsigned-byte))
     416              (progn
     417                (argforms arg-type-spec)
     418                (argforms arg-value-form))
     419              (let* ((ftype (parse-foreign-type arg-type-spec)))
     420                (if (typep ftype 'foreign-record-type)
     421                  (progn
     422                    (argforms :address)
     423                    (argforms arg-value-form))
     424                  (progn
     425                    (argforms (foreign-type-to-representation-type ftype))
     426                    (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
     427        (argforms (foreign-type-to-representation-type result-type))
     428        (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
     429          (if enclosing-form
     430            `(,@enclosing-form ,call)
     431            call))))))
     432
     433(defun arm::eabi-generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
     434  (declare (ignore fp-args-ptr))
     435  (collect ((lets)
     436            (rlets)
     437            (dynamic-extent-names))
     438    (let* ((rtype (parse-foreign-type result-spec)))
     439      (when (typep rtype 'foreign-record-type)
     440        (let* ((bits (ensure-foreign-type-bits rtype)))
     441          (if (<= bits 64)
     442            (rlets (list struct-result-name (foreign-record-type-name rtype)))
     443            (setq argvars (cons struct-result-name argvars)
     444                  argspecs (cons :address argspecs)
     445                  rtype *void-foreign-type*))))
     446          (let* ((offset 0)
     447                 (nextoffset offset))
     448            (do* ((argvars argvars (cdr argvars))
     449                  (argspecs argspecs (cdr argspecs)))
     450                 ((null argvars)
     451                  (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#))
     452              (let* ((name (car argvars))
     453                     (spec (car argspecs))
     454                     (argtype (parse-foreign-type spec)))
     455                (if (typep argtype 'foreign-record-type)
     456                  (setq argtype (parse-foreign-type :address)))
     457                (let* ((access-form
     458                        `(,(cond
     459                            ((typep argtype 'foreign-single-float-type)
     460                             (setq nextoffset (+ offset 4))
     461                             '%get-single-float)
     462                            ((typep argtype 'foreign-double-float-type)
     463                             (when (logtest offset 4)
     464                               (incf offset 4))
     465                             (setq nextoffset (+ offset 8))
     466                             '%get-double-float)
     467                            ((and (typep argtype 'foreign-integer-type)
     468                                  (= (foreign-integer-type-bits argtype) 64)
     469                                  (foreign-integer-type-signed argtype))
     470                             (when (logtest offset 4)
     471                               (incf offset 4))
     472                             (setq nextoffset (+ offset 8))
     473                             '%%get-signed-longlong)
     474                            ((and (typep argtype 'foreign-integer-type)
     475                                  (= (foreign-integer-type-bits argtype) 64)
     476                                  (not (foreign-integer-type-signed argtype)))
     477                             (when (logtest offset 4)
     478                               (incf offset 4))
     479                             (setq nextoffset (+ offset 8))
     480                             '%%get-unsigned-longlong)
     481                            (t
     482                             (setq nextoffset (+ offset 4))
     483                             (cond ((typep argtype 'foreign-pointer-type) '%get-ptr)
     484                                   ((typep argtype 'foreign-integer-type)
     485                                    (let* ((bits (foreign-integer-type-bits argtype))
     486                                           (signed (foreign-integer-type-signed argtype)))
     487                                      (cond ((<= bits 8)
     488                                             (if signed
     489                                               '%get-signed-byte
     490                                               '%get-unsigned-byte))
     491                                            ((<= bits 16)
     492                                             (if signed
     493                                               '%get-signed-word
     494                                               '%get-unsigned-word))
     495                                            ((<= bits 32)
     496                                             (if signed
     497                                               '%get-signed-long
     498                                               '%get-unsigned-long))
     499                                            (t
     500                                             (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
     501                                   (t
     502                                    (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
     503                          ,stack-ptr
     504                          ,offset)))
     505                  (when name (lets (list name access-form)))
     506                  (setq offset nextoffset))))))))
     507
     508(defun arm::eabi-generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
     509  (declare (ignore fp-args-ptr))
     510  (unless (eq return-type *void-foreign-type*)
     511    (let* ((return-type-keyword
     512            (if (typep return-type 'foreign-record-type)
     513              (progn
     514                (setq result `(%%get-unsigned-longlong ,struct-return-arg 0))
     515                :unsigned-doubleword)
     516              (foreign-type-to-representation-type return-type)))
     517           (offset -8))
     518      `(setf (,
     519              (case return-type-keyword
     520                (:address '%get-ptr)
     521                (:signed-doubleword '%%get-signed-longlong)
     522                (:unsigned-doubleword '%%get-unsigned-longlong)
     523                (:double-float '%get-double-float)
     524                (:single-float '%get-single-float)
     525                (:unsigned-fullword '%get-unsigned-long)
     526                (t '%get-long)) ,stack-ptr ,offset) ,result))))
     527
    372528#+arm-target
    373529(require "ARM-VINSNS")

  • trunk/source/level-1/l1-aprims.lisp

    r14521 r14548  
    36573657  (:use "COMMON-LISP"))
    36583658
    3659 ;;; androidarm uses the same FFI as linuxarm
    3660 #+androidarm-target
    3661 (defpackage "ARM-LINUX"
    3662   (:use "COMMON-LISP"))
    3663 
    3664 
    3665 
    3666 
     3659
     3660
     3661
     3662
     3663

  • trunk/source/level-1/l1-boot-2.lisp

    r14421 r14548  
    321321      #+freebsdx8632-target
    322322      (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632")
    323       #+(and arm-target linux-target)
     323      #+(and arm-target linux-target (not android-target))
    324324      (bin-load-provide "FFI-LINUXARM" "ffi-linuxarm")
     325      #+(and arm-target android-target)
     326      (bin-load-provide "FFI-ANDROIDARM" "ffi-androidarm")
    325327      #+(and arm-target darwin-target)
    326328      (bin-load-provide "FFI-DARWINARM" "ffi-darwinarm")

  • trunk/source/lib/compile-ccl.lisp

    r14510 r14548  
    159159             (:solarisx8632 'ffi-solarisx8632)
    160160             (:freebsdx8632 'ffi-freebsdx8632)
    161              ((:linuxarm :androidarm) 'ffi-linuxarm)
     161             (:linuxarm 'ffi-linuxarm)
     162             (:androidarm 'ffi-androidarm)
    162163             (:darwinarm 'ffi-darwinarm)))))
    163164

  • trunk/source/lib/ffi-linuxarm.lisp

    r14479 r14548  
    2222;;; Structures whose size is <= 32 bits are returned as scalars.
    2323(defun arm-linux::record-type-returns-structure-as-first-arg (rtype)
    24   (when (and rtype
    25              (not (typep rtype 'unsigned-byte))
    26              (not (member rtype *foreign-representation-type-keywords*
    27                           :test #'eq)))
    28     (let* ((ftype (if (typep rtype 'foreign-type)
    29                     rtype
    30                     (parse-foreign-type rtype))))
    31       (when (typep ftype 'foreign-record-type)
    32         (ensure-foreign-type-bits ftype)
    33         (> (foreign-type-bits ftype) 32)))))
     24  (arm::eabi-record-type-returns-structure-as-first-arg rtype))
    3425
    3526
    3627(defun arm-linux::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    37   (let* ((result-type-spec (or (car (last args)) :void))
    38          (enclosing-form nil)
    39          (result-form nil))
    40     (multiple-value-bind (result-type error)
    41         (ignore-errors (parse-foreign-type result-type-spec))
    42       (if error
    43         (setq result-type-spec :void result-type *void-foreign-type*)
    44         (setq args (butlast args)))
    45       (collect ((argforms))
    46         (when (typep result-type 'foreign-record-type)
    47           (setq result-form (pop args))
    48           (if (arm-linux::record-type-returns-structure-as-first-arg result-type)
    49             (progn
    50               (setq result-type *void-foreign-type*
    51                     result-type-spec :void)
    52               (argforms :address)
    53               (argforms result-form))
    54             ;; This only happens in the SVR4 ABI.
    55             (progn
    56               (setq result-type (parse-foreign-type :unsigned-doubleword)
    57                     result-type-spec :unsigned-doubleword
    58                     enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0))))))
    59         (unless (evenp (length args))
    60           (error "~s should be an even-length list of alternating foreign types and values" args))       
    61         (do* ((args args (cddr args)))
    62              ((null args))
    63           (let* ((arg-type-spec (car args))
    64                  (arg-value-form (cadr args)))
    65             (if (or (member arg-type-spec *foreign-representation-type-keywords*
    66                            :test #'eq)
    67                     (typep arg-type-spec 'unsigned-byte))
    68               (progn
    69                 (argforms arg-type-spec)
    70                 (argforms arg-value-form))
    71               (let* ((ftype (parse-foreign-type arg-type-spec)))
    72                 (if (typep ftype 'foreign-record-type)
    73                   (progn
    74                     (argforms :address)
    75                     (argforms arg-value-form))
    76                   (progn
    77                     (argforms (foreign-type-to-representation-type ftype))
    78                     (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
    79         (argforms (foreign-type-to-representation-type result-type))
    80         (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
    81           (if enclosing-form
    82             `(,@enclosing-form ,call)
    83             call))))))
     28  (arm::eabi-expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce))
    8429
    8530;;; Return 7 values:
    … …  
    9338;;; The byte offset of the foreign return address, relative to STACK-PTR
    9439(defun arm-linux::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
    95   (declare (ignore fp-args-ptr))
    96   (collect ((lets)
    97             (rlets)
    98             (dynamic-extent-names))
    99     (let* ((rtype (parse-foreign-type result-spec)))
    100       (when (typep rtype 'foreign-record-type)
    101         (let* ((bits (ensure-foreign-type-bits rtype)))
    102           (if (<= bits 64)
    103             (rlets (list struct-result-name (foreign-record-type-name rtype)))
    104             (setq argvars (cons struct-result-name argvars)
    105                   argspecs (cons :address argspecs)
    106                   rtype *void-foreign-type*))))
    107           (let* ((offset 0)
    108                  (nextoffset offset))
    109             (do* ((argvars argvars (cdr argvars))
    110                   (argspecs argspecs (cdr argspecs)))
    111                  ((null argvars)
    112                   (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#))
    113               (let* ((name (car argvars))
    114                      (spec (car argspecs))
    115                      (argtype (parse-foreign-type spec)))
    116                 (if (typep argtype 'foreign-record-type)
    117                   (setq argtype (parse-foreign-type :address)))
    118                 (let* ((access-form
    119                         `(,(cond
    120                             ((typep argtype 'foreign-single-float-type)
    121                              (setq nextoffset (+ offset 4))
    122                              '%get-single-float)
    123                             ((typep argtype 'foreign-double-float-type)
    124                              (when (logtest offset 4)
    125                                (incf offset 4))
    126                              (setq nextoffset (+ offset 8))
    127                              '%get-double-float)
    128                             ((and (typep argtype 'foreign-integer-type)
    129                                   (= (foreign-integer-type-bits argtype) 64)
    130                                   (foreign-integer-type-signed argtype))
    131                              (when (logtest offset 4)
    132                                (incf offset 4))
    133                              (setq nextoffset (+ offset 8))
    134                              '%%get-signed-longlong)
    135                             ((and (typep argtype 'foreign-integer-type)
    136                                   (= (foreign-integer-type-bits argtype) 64)
    137                                   (not (foreign-integer-type-signed argtype)))
    138                              (when (logtest offset 4)
    139                                (incf offset 4))
    140                              (setq nextoffset (+ offset 8))
    141                              '%%get-unsigned-longlong)
    142                             (t
    143                              (setq nextoffset (+ offset 4))
    144                              (cond ((typep argtype 'foreign-pointer-type) '%get-ptr)
    145                                    ((typep argtype 'foreign-integer-type)
    146                                     (let* ((bits (foreign-integer-type-bits argtype))
    147                                            (signed (foreign-integer-type-signed argtype)))
    148                                       (cond ((<= bits 8)
    149                                              (if signed
    150                                                '%get-signed-byte
    151                                                '%get-unsigned-byte))
    152                                             ((<= bits 16)
    153                                              (if signed
    154                                                '%get-signed-word
    155                                                '%get-unsigned-word))
    156                                             ((<= bits 32)
    157                                              (if signed
    158                                                '%get-signed-long
    159                                                '%get-unsigned-long))
    160                                             (t
    161                                              (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
    162                                    (t
    163                                     (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
    164                           ,stack-ptr
    165                           ,offset)))
    166                   (when name (lets (list name access-form)))
    167                   (setq offset nextoffset))))))))
     40  (arm::eabi-generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name))
    16841
    16942
    17043(defun arm-linux::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
    171   (declare (ignore fp-args-ptr))
    172   (unless (eq return-type *void-foreign-type*)
    173     (let* ((return-type-keyword
    174             (if (typep return-type 'foreign-record-type)
    175               (progn
    176                 (setq result `(%%get-unsigned-longlong ,struct-return-arg 0))
    177                 :unsigned-doubleword)
    178               (foreign-type-to-representation-type return-type)))
    179            (offset -8))
    180       `(setf (,
    181               (case return-type-keyword
    182                 (:address '%get-ptr)
    183                 (:signed-doubleword '%%get-signed-longlong)
    184                 (:unsigned-doubleword '%%get-unsigned-longlong)
    185                 (:double-float '%get-double-float)
    186                 (:single-float '%get-single-float)
    187                 (:unsigned-fullword '%get-unsigned-long)
    188                 (t '%get-long)) ,stack-ptr ,offset) ,result))))
     44  (arm::eabi-generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg))
    18945     
    19046                 

  • trunk/source/lib/systems.lisp

    r14421 r14548  
    1 ;;;-*-Mode: LISP; Package: CCL -*-
     1;-*-Mode: LISP; Package: CCL -*-
    22;;;
    33;;;   Copyright (C) 2009 Clozure Associates
    … …  
    165165    (ffi-linuxarm     "ccl:bin;ffi-linuxarm"     ("ccl:lib;ffi-linuxarm.lisp"))
    166166    (ffi-darwinarm    "ccl:bin;ffi-darwinarm"    ("ccl:lib;ffi-darwinarm.lisp"))
     167    (ffi-androidarm     "ccl:bin;ffi-androidarm"     ("ccl:lib;ffi-androidarm.lisp"))
    167168    (db-io            "ccl:bin;db-io"            ("ccl:lib;db-io.lisp"))
    168169    (hash             "ccl:bin;hash"             ("ccl:lib;hash.lisp"))
Note: See TracChangeset for help on using the changeset viewer.