Changeset 15431


Ignore:
Timestamp:
Aug 4, 2012, 4:19:48 AM (7 years ago)
Author:
gb
Message:

lib/macros.lisp: DEFCALLBACK-BODY expands into LET*, not LET. (Matters

on ARM, likely doesn't for other architectures.)

compiler/ARM/arm2.lisp: unsafe optimization in ARM2-GET-FLOAT.
compiler/ARM/arm-backend.lisp: handle hard-float conventions in callbacks

on ARM. Fixes ticket:1000

level-0/ARM/arm-def.lisp: in %FF-CALL-HARD-FLOAT, don't preincrement

FP-ARG-OFFSET in the :SINGLE-FLOAT case.

Location:
trunk/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/ARM/arm-backend.lisp

    r15093 r15431  
    431431            call))))))
    432432
    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))
     433(defun arm::eabi-generate-float-callback-bindings (stack-ptr  argvars argspecs result-spec struct-result-name)
    435434  (collect ((lets)
    436435            (rlets)
    437436            (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))))))))
     437    (let* ((hard-float-p (gensym)))
     438      (lets `(,hard-float-p (arm-hard-float-p)))
     439      (let* ((rtype (parse-foreign-type result-spec)))
     440        (when (typep rtype 'foreign-record-type)
     441          (let* ((bits (ensure-foreign-type-bits rtype)))
     442            (if (<= bits 64)
     443              (rlets (list struct-result-name (foreign-record-type-name rtype)))
     444              (setq argvars (cons struct-result-name argvars)
     445                    argspecs (cons :address argspecs)
     446                    rtype *void-foreign-type*))))
     447        (let* ((reg-offset 0)
     448               (gen-offset 0)
     449               (fp-offset -72)
     450               (stack-offset 16))
     451          (do* ((argvars argvars (cdr argvars))
     452                (argspecs argspecs (cdr argspecs)))
     453               ((null argvars)
     454                (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#))
     455            (let* ((name (car argvars))
     456                   (spec (car argspecs))
     457                   (argtype (parse-foreign-type spec))
     458                   (accessor nil)
     459                   (offsetform nil))
     460              (if (typep argtype 'foreign-record-type)
     461                (setq argtype (parse-foreign-type :address)))
     462              (typecase argtype
     463                (foreign-single-float-type
     464                 (setq accessor '%get-single-float
     465                       offsetform `(if ,hard-float-p
     466                                    ,(if (< fp-offset -8)
     467                                         (prog1 fp-offset
     468                                           (incf fp-offset 4))
     469                                         (prog1 stack-offset
     470                                           (incf stack-offset 4)))
     471                                    ,(prog1 gen-offset
     472                                            (incf gen-offset 4)))))
     473                (foreign-double-float-type
     474                 (when (logtest 7 fp-offset)
     475                   (incf fp-offset 4))
     476                 (when (and (>= fp-offset -8)
     477                            (logtest 7 stack-offset))
     478                   (incf stack-offset 4))
     479                 (when (logtest 7 gen-offset)
     480                   (incf gen-offset 4))
     481                 (setq accessor '%get-double-float
     482                       offsetform `(if ,hard-float-p
     483                                    ,(if (< fp-offset -8)
     484                                         (prog1 fp-offset
     485                                           (incf fp-offset 8))
     486                                         (prog1 stack-offset
     487                                           (incf stack-offset 8)))
     488                                    ,(prog1 gen-offset
     489                                            (incf gen-offset 8)))))
     490                (foreign-pointer-type
     491                 (setq accessor '%get-ptr
     492                       offsetform `(if ,hard-float-p
     493                                    ,(if (< reg-offset 16)
     494                                         (prog1 reg-offset
     495                                           (incf reg-offset 4))
     496                                         (prog1 stack-offset
     497                                           (incf stack-offset 4)))
     498                                    ,(prog1 gen-offset
     499                                            (incf gen-offset 4)))))
     500                (foreign-integer-type
     501                 (let* ((nbits (foreign-type-bits argtype))
     502                        (nbytes (cond ((> nbits 32) 8)
     503                                      ((> nbits 16) 4)
     504                                      ((> nbits 8) 2)
     505                                      (t 1)))
     506                        (align (if (= nbytes 8) 8 4))
     507                        (signed (foreign-integer-type-signed argtype)))
     508                   (when (= align 8)
     509                     (when (logtest 7 reg-offset)
     510                       (incf reg-offset 4))
     511                     (when (and (>= reg-offset 16)
     512                                (logtest 7 stack-offset))
     513                       (incf stack-offset 4))
     514                     (when (logtest 7 gen-offset)
     515                       (incf gen-offset 4)))
     516                   (setq accessor
     517                         (case nbytes
     518                           (8 (if signed '%%get-signed-longlong '%%get-unsigned-longlong))
     519                           (4 (if signed '%get-signed-long '%get-unsigned-long))
     520                           (2 (if signed '%get-signed-word '%get-unsigned-word))
     521                           (1 (if signed '%get-signed-byte '%get-unsigned-byte)))
     522                         offsetform `(if ,hard-float-p
     523                                      ,(if (<= (+ reg-offset nbytes) 16)
     524                                           (prog1 reg-offset
     525                                             (incf reg-offset nbytes))
     526                                           (prog1 stack-offset
     527                                             (incf stack-offset nbytes)))
     528                                      ,(prog1 gen-offset
     529                                              (incf gen-offset nbytes)))))))
     530              (when name (lets `(,name (,accessor ,stack-ptr ,offsetform)))))))))))
     531
     532(defun arm::eabi-generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
     533  (declare (ignore fp-args-ptr))
     534  (if (dolist (argtype argspecs)
     535        (let* ((ftype (parse-foreign-type argtype)))
     536          (when (or (typep ftype 'foreign-single-float-type)
     537                    (typep ftype 'foreign-double-float-type))
     538            (return t))))
     539    (arm::eabi-generate-float-callback-bindings stack-ptr argvars argspecs result-spec struct-result-name)
     540    (collect ((lets)
     541              (rlets)
     542              (dynamic-extent-names))
     543      (let* ((rtype (parse-foreign-type result-spec)))
     544        (when (typep rtype 'foreign-record-type)
     545          (let* ((bits (ensure-foreign-type-bits rtype)))
     546            (if (<= bits 64)
     547              (rlets (list struct-result-name (foreign-record-type-name rtype)))
     548              (setq argvars (cons struct-result-name argvars)
     549                    argspecs (cons :address argspecs)
     550                    rtype *void-foreign-type*))))
     551        (let* ((offset 0)
     552               (nextoffset offset))
     553          (do* ((argvars argvars (cdr argvars))
     554                (argspecs argspecs (cdr argspecs)))
     555               ((null argvars)
     556                (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#))
     557            (let* ((name (car argvars))
     558                   (spec (car argspecs))
     559                   (argtype (parse-foreign-type spec)))
     560              (if (typep argtype 'foreign-record-type)
     561                (setq argtype (parse-foreign-type :address)))
     562              (let* ((access-form
     563                      `(,(cond
     564                          ((typep argtype 'foreign-single-float-type)
     565                           (setq nextoffset (+ offset 4))
     566                           '%get-single-float)
     567                          ((typep argtype 'foreign-double-float-type)
     568                           (when (logtest offset 4)
     569                             (incf offset 4))
     570                           (setq nextoffset (+ offset 8))
     571                           '%get-double-float)
     572                          ((and (typep argtype 'foreign-integer-type)
     573                                (= (foreign-integer-type-bits argtype) 64)
     574                                (foreign-integer-type-signed argtype))
     575                           (when (logtest offset 4)
     576                             (incf offset 4))
     577                           (setq nextoffset (+ offset 8))
     578                           '%%get-signed-longlong)
     579                          ((and (typep argtype 'foreign-integer-type)
     580                                (= (foreign-integer-type-bits argtype) 64)
     581                                (not (foreign-integer-type-signed argtype)))
     582                           (when (logtest offset 4)
     583                             (incf offset 4))
     584                           (setq nextoffset (+ offset 8))
     585                           '%%get-unsigned-longlong)
     586                          (t
     587                           (setq nextoffset (+ offset 4))
     588                           (cond ((typep argtype 'foreign-pointer-type) '%get-ptr)
     589                                 ((typep argtype 'foreign-integer-type)
     590                                  (let* ((bits (foreign-integer-type-bits argtype))
     591                                         (signed (foreign-integer-type-signed argtype)))
     592                                    (cond ((<= bits 8)
     593                                           (if signed
     594                                             '%get-signed-byte
     595                                             '%get-unsigned-byte))
     596                                          ((<= bits 16)
     597                                           (if signed
     598                                             '%get-signed-word
     599                                             '%get-unsigned-word))
     600                                          ((<= bits 32)
     601                                           (if signed
     602                                             '%get-signed-long
     603                                             '%get-unsigned-long))
     604                                          (t
     605                                           (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
     606                                 (t
     607                                  (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
     608                        ,stack-ptr
     609                        ,offset)))
     610                (when name (lets (list name access-form)))
     611                (setq offset nextoffset)))))))))
    507612
    508613(defun arm::eabi-generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
  • trunk/source/compiler/ARM/arm2.lisp

    r15425 r15431  
    74917491                                                    ptr ptrreg
    74927492                                                    offset offsetreg))
    7493                    (let* ((last (dll-node-pred seg)))
    7494                      (if (and (typep last 'vinsn)
    7495                               (eq (vinsn-template-name (vinsn-template last)) 'lri)
    7496                               (typep (setq fixoffset (ash (svref (vinsn-variable-parts last) 1) (- arm::fixnumshift)))
    7497                                      '(signed-byte 10))
    7498                               (not (logtest fixoffset #x3)))
    7499                        (progn
    7500                          (elide-vinsn last)
    7501                          (if double-p
    7502                            (! mem-ref-c-double-float fp-reg ptrreg fixoffset)
    7503                            (! mem-ref-c-single-float fp-reg ptrreg fixoffset)))
    7504                        (progn
     7493                   (progn
    75057494                         (if double-p
    75067495                           (! mem-ref-double-float fp-reg ptrreg offsetreg)
    7507                            (! mem-ref-single-float fp-reg ptrreg offsetreg))))))))
     7496                           (! mem-ref-single-float fp-reg ptrreg offsetreg))))))
    75087497             (<- fp-reg))
    75097498           (^)))))
  • trunk/source/level-0/ARM/arm-def.lisp

    r15339 r15431  
    549549                           (:single-float
    550550                            (cond ((< fp-arg-offset 72)
    551                                    (incf fp-arg-offset 4)
    552551                                   (setf (%get-single-float argptr fp-arg-offset) val)
    553552                                   (incf fp-arg-offset 4))
  • trunk/source/lib/macros.lisp

    r15378 r15431  
    27292729           (body
    27302730            `(rlet ,rlets
    2731               (let ,lets
     2731              (let* ,lets
    27322732                ,dynamic-extent-decls
    27332733                ,@other-decls
Note: See TracChangeset for help on using the changeset viewer.