Changeset 14159


Ignore:
Timestamp:
Aug 9, 2010, 10:31:00 AM (9 years ago)
Author:
gb
Message:

Unscramble variable-c-frame stuff. Use it to implement #'%FF-CALL.

Location:
trunk/source
Files:
3 edited

Legend:

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

    r14119 r14159  
    19751975  (str prevsp (:@ sp (:$ 4))))
    19761976
    1977 (define-arm-vinsn (alloc-variable-c-frame :predicatable)
     1977(define-arm-vinsn (alloc-variable-eabi-c-frame :predicatable)
    19781978    (()
    19791979     ((n-c-args :lisp))
     
    19811981      (size :imm)
    19821982      (prevsp :imm)))
    1983   (add size n-c-args (:$ (ash (+ 4 1) arm::word-shift)))
     1983  (add size n-c-args (:$ (ash (+ 4 4 1) arm::word-shift)))
    19841984  (bic size size (:$ arm::fixnumone))
    19851985  (add size size (:$ arm::fixnumone))
  • trunk/source/compiler/ARM/arm2.lisp

    r14119 r14159  
    84708470  (let* ((reg (arm2-one-untargeted-reg-form seg size arm::arg_z)))
    84718471    (ecase (backend-name *target-backend*)
    8472       (:linuxarm32 (! alloc-variable-eabi-c-frame reg))
    8473       ((:darwinarm32 :darwinarm64 :linuxarm64) (! alloc-variable-c-frame reg)))
     8472      (:linuxarm (! alloc-variable-eabi-c-frame reg)))
    84748473    (arm2-open-undo $undo-arm-c-frame)
    84758474    (arm2-undo-body seg vreg xfer body old-stack)))
  • trunk/source/level-0/ARM/arm-def.lisp

    r14119 r14159  
    294294  (return-lisp-frame))
    295295
    296 #+notyet
    297 (progn
    298 ;;; FF-call, in LAP.
    299 #+eabi-target
    300 (progn
    301   (defarmlapfunction %%ff-call ((fploads 8)
    302                                 (single-offset 4)
    303                                 (double-offset 0)
    304                                 (framesize arg_x) ;always even, negative, includes frame overhead
    305                                 (buf arg_y)
    306                                 (entry arg_z))
    307     (check-nargs 6)
    308     (la imm0 12 vsp)
    309     (save-lisp-context imm0)
    310     (stwux sp sp framesize)
    311     (stw sp 4 sp)
    312     (macptr-ptr imm2 buf)
    313     (mov imm1 imm2)
    314     (la imm3 ppc32::eabi-c-frame.param0 sp)
    315     (li imm0 0)
    316     (lwz temp1 single-offset vsp)
    317     (lwz temp2 double-offset vsp)
    318     @copy
    319     (addi imm0 imm0 8)
    320     (cmpw imm0 temp1)
    321     (lfd fp0 0 imm2)
    322     (la imm2 8 imm2)
    323     (stfd fp0 0 imm3)
    324     (la imm3 8 imm3)
    325     (blt @copy)
    326     ;; We've copied the gpr-save area and the "other" arg words.
    327     ;; Sadly, we may still need to load up to 8 FPRs, and we have
    328     ;; to use some pretty ugly code to do so.
    329     (add temp1 temp1 imm1)
    330     (add temp2 temp2 imm1)
    331     (lwz temp0 fploads vsp)
    332     @load-fp1
    333     (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
    334     (cmpwi imm0 1)
    335     (blt @loaded)
    336     (bne @load-fp1-double)
    337     (lfs fp1 0 temp1)
    338     (la temp1 4 temp1)
    339     (b @load-fp2)
    340     @load-fp1-double
    341     (lfd fp1 0 temp2)
    342     (la temp2 8 temp2)
    343     @load-fp2
    344     (lbz imm0 (+ ppc32::misc-data-offset 1) temp0)
    345     (cmpwi imm0 1)
    346     (blt @loaded)
    347     (bne @load-fp2-double)
    348     (lfs fp2 0 temp1)
    349     (la temp1 4 temp1)
    350     (b @load-fp3)
    351     @load-fp2-double
    352     (lfd fp2 0 temp2)
    353     (la temp2 8 temp2)
    354     @load-fp3
    355     (lbz imm0 (+ ppc32::misc-data-offset 2) temp0)
    356     (cmpwi imm0 1)
    357     (blt @loaded)
    358     (bne @load-fp3-double)
    359     (lfs fp3 0 temp1)
    360     (la temp1 4 temp1)
    361     (b @load-fp4)
    362     @load-fp3-double
    363     (lfd fp3 0 temp2)
    364     (la temp2 8 temp2)
    365     @load-fp4
    366     (lbz imm0 (+ ppc32::misc-data-offset 3) temp0)
    367     (cmpwi imm0 1)
    368     (blt @loaded)
    369     (bne @load-fp4-double)
    370     (lfs fp4 0 temp1)
    371     (la temp1 4 temp1)
    372     (b @load-fp5)
    373     @load-fp4-double
    374     (lfd fp4 0 temp2)
    375     (la temp2 8 temp2)
    376     @load-fp5
    377     (lbz imm0 (+ ppc32::misc-data-offset 4) temp0)
    378     (cmpwi imm0 1)
    379     (blt @loaded)
    380     (bne @load-fp5-double)
    381     (lfs fp5 0 temp1)
    382     (la temp1 4 temp1)
    383     (b @load-fp6)
    384     @load-fp5-double
    385     (lfd fp5 0 temp2)
    386     (la temp2 8 temp2)
    387     @load-fp6
    388     (lbz imm0 (+ ppc32::misc-data-offset 5) temp0)
    389     (cmpwi imm0 1)
    390     (blt @loaded)
    391     (bne @load-fp6-double)
    392     (lfs fp6 0 temp1)
    393     (la temp1 4 temp1)
    394     (b @load-fp7)
    395     @load-fp6-double
    396     (lfd fp6 0 temp2)
    397     (la temp2 8 temp2)
    398     @load-fp7
    399     (lbz imm0 (+ ppc32::misc-data-offset 6) temp0)
    400     (cmpwi imm0 1)
    401     (blt @loaded)
    402     (bne @load-fp7-double)
    403     (lfs fp7 0 temp1)
    404     (la temp1 4 temp1)
    405     (b @load-fp8)
    406     @load-fp7-double
    407     (lfd fp7 0 temp2)
    408     (la temp2 8 temp2)
    409     @load-fp8
    410     (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
    411     (cmpwi imm0 1)
    412     (blt @loaded)
    413     (bne @load-fp8-double)
    414     (lfs fp8 0 temp1)
    415     (b @loaded)
    416     @load-fp8-double
    417     (lfd fp8 0 temp2)
    418     @loaded
    419     (vpush buf)
    420     (bla .SPeabi-ff-call)
    421     (vpop buf)
    422     (macptr-ptr imm2 buf)
    423     (stw imm0 0 imm2)
    424     (stw imm1 4 imm2)
    425     (stfs fp1 8 imm2)
    426     (stfd fp1 16 imm2)
    427     (restore-full-lisp-context)
    428     (li arg_z (target-nil-value))
    429     (bx lr))
     296(defarmlapfunction %do-ff-call ((tag arg_x) (result arg_y) (entry arg_z))
     297  (stmdb (:! vsp) (tag result))
     298  (bla .SPeabi-ff-call)
     299  (ldmia (:! vsp) (tag result))
     300  (macptr-ptr imm2 result)
     301  (str imm0 (:@ imm2 (:$ 0)))
     302  (str imm1 (:@ imm2 (:$ 4)))
     303  (vpush1 tag)
     304  (mov arg_z 'nil)
     305  (vpush1 arg_z)
     306  (set-nargs 1)
     307  (bla .SPthrow))
    430308 
    431   (defun %ff-call (entry &rest specs-and-vals)
    432     "Call the foreign function at address entrypoint passing the values of
    433 each arg as a foreign argument of type indicated by the corresponding
    434 arg-type-keyword. Returns the foreign function result (coerced to a Lisp
    435 object of type indicated by result-type-keyword), or NIL if
    436 result-type-keyword is :VOID or NIL"
    437     (declare (dynamic-extent specs-and-vals))
    438     (let* ((len (length specs-and-vals))
    439            (other-offset 8)
    440            (single-float-offset 8)
    441            (double-float-offset 0)
    442            (nsingle-floats 0)
    443            (ndouble-floats 0)
    444            (nother-words 0)
    445            (nfpr-args 0)
    446            (ngpr-args 0))
    447       (declare (fixnum len  other-offset single-float-offset double-float-offset
    448                        nsingle-floats ndouble-floats nother-words nfpr-args ngpr-args))
    449       (unless (oddp len)
    450         (error "Length of ~s is even.  Missing result ?" specs-and-vals))
    451 
    452       (let* ((result-spec (or (car (last specs-and-vals)) :void))
    453              (nargs (ash (the fixnum (1- len)) -1))
    454              (fpr-reloads (make-array 8 :element-type '(unsigned-byte 8))))
    455         (declare (fixnum nargs) (dynamic-extent fpr-reloads))
    456         (do* ((i 0 (1+ i))
    457               (specs specs-and-vals (cddr specs))
    458               (spec (car specs) (car specs)))
    459              ((= i nargs))
    460           (declare (fixnum i))
    461           (ecase spec
    462             (:double-float (incf nfpr-args)
    463                            (if (<= nfpr-args 8)
    464                              (incf ndouble-floats)
    465                              (progn
    466                                (if (oddp nother-words)
    467                                  (incf nother-words))
    468                                (incf nother-words 2))))
    469             (:single-float (incf nfpr-args)
    470                            (if (<= nfpr-args 8)
    471                              (incf nsingle-floats)
    472                              (incf nother-words)))
    473             ((:signed-doubleword :unsigned-doubleword)
    474              (if (oddp ngpr-args)
    475                (incf ngpr-args))
    476              (incf ngpr-args 2)
    477              (when (> ngpr-args 8)
    478                (if (oddp nother-words)
    479                  (incf nother-words))
    480                (incf nother-words 2)))
    481             ((:signed-byte :unsigned-byte :signed-halfword :unsigned-halfword
    482                            :signed-fullword :unsigned-fullword :address)
    483              (incf ngpr-args)
    484              (if (> ngpr-args 8)
    485                (incf nother-words)))))
    486         (let* ((single-words (+ 8 nother-words nsingle-floats))
    487                (total-words (if (zerop ndouble-floats)
    488                               single-words
    489                               (+ (the fixnum (+ ndouble-floats ndouble-floats))
    490                                  (the fixnum (logand (lognot 1)
    491                                                      (the fixnum (1+ single-words))))))))
    492           (declare (fixnum total-words single-words))
    493           (%stack-block
    494               ((buf (ash total-words 2)))
    495             (setq single-float-offset (+ other-offset nother-words))
    496             (setq double-float-offset
    497                   (logand (lognot 1)
    498                           (the fixnum (1+ (the fixnum (+ single-float-offset nsingle-floats))))))
    499            ;;; Make another pass through the arg/value pairs, evaluating each arg into
    500            ;;; the buffer.
    501             (do* ((i 0 (1+ i))
    502                   (specs specs-and-vals (cddr specs))
    503                   (spec (car specs) (car specs))
    504                   (val (cadr specs) (cadr specs))
    505                   (ngpr 0)
    506                   (nfpr 0)
    507                   (gpr-byte-offset 0)
    508                   (other-byte-offset (ash other-offset 2))
    509                   (single-byte-offset (ash single-float-offset 2))
    510                   (double-byte-offset (ash double-float-offset 2)))
    511                  ((= i nargs))
    512               (declare (fixnum i gpr-byte-offset single-byte-offset double-byte-offset
    513                                ngpr nfpr))
    514               (case spec
    515                 (:double-float
    516                  (cond ((< nfpr 8)
    517                         (setf (uvref fpr-reloads nfpr) 2
    518                               (%get-double-float buf double-byte-offset) val
    519                               double-byte-offset (+ double-byte-offset 8)))
    520                        (t
    521                         (setq other-byte-offset (logand (lognot 7)
    522                                                         (the fixnum (+ other-byte-offset 4))))
    523                         (setf (%get-double-float buf other-byte-offset) val)
    524                         (setq other-byte-offset (+ other-byte-offset 8))))
    525                  (incf nfpr))
    526                 (:single-float
    527                  (cond ((< nfpr 8)
    528                         (setf (uvref fpr-reloads nfpr) 1
    529                               (%get-single-float buf single-byte-offset) val
    530                               single-byte-offset (+ single-byte-offset 4)))
    531                              
    532                        (t
    533                         (setf (%get-single-float buf other-byte-offset) val
    534                               other-byte-offset (+ other-byte-offset 4))))
    535                  (incf nfpr))
    536                 (:address
    537                  (cond ((< ngpr 8)
    538                         (setf (%get-ptr buf gpr-byte-offset) val
    539                               gpr-byte-offset (+ gpr-byte-offset 4)))
    540                        (t
    541                         (setf (%get-ptr buf other-byte-offset) val
    542                               other-byte-offset (+ other-byte-offset 4))))
    543                  (incf ngpr))
    544                 ((:signed-doubleword :unsigned-doubleword)
    545                  (when (oddp ngpr)
    546                    (incf ngpr)
    547                    (incf gpr-byte-offset 4))
    548                  (cond ((< ngpr 8)
    549                         (if (eq spec :signed-doubleword)
    550                           (setf (%get-signed-long-long buf gpr-byte-offset) val)
    551                           (setf (%get-unsigned-long-long buf gpr-byte-offset) val))
    552                         (incf gpr-byte-offset 8))
    553                        (t
    554                         (when (logtest other-byte-offset 7)
    555                           (incf other-byte-offset 4))
    556                         (if (eq spec :signed-doubleword)
    557                           (setf (%get-signed-long-long buf other-byte-offset) val)
    558                           (setf (%get-unsigned-long-long buf other-byte-offset) val))
    559                         (incf other-byte-offset 8)))
    560                  (incf ngpr 2))
    561                 ((:unsigned-byte :unsigned-halfword :unsigned-fullword)
    562                  (cond ((< ngpr 8)
    563                         (setf (%get-unsigned-long buf gpr-byte-offset) val
    564                               gpr-byte-offset (+ gpr-byte-offset 4)))
    565                        (t
    566                         (setf (%get-unsigned-long buf other-byte-offset) val
    567                               other-byte-offset (+ other-byte-offset 4))))
    568                  (incf ngpr))
    569                 (t
    570                  (cond ((< ngpr 8)
    571                         (setf (%get-long buf gpr-byte-offset) val
    572                               gpr-byte-offset (+ gpr-byte-offset 4)))
    573                        (t
    574                         (setf (%get-long buf other-byte-offset) val
    575                               other-byte-offset (+ other-byte-offset 4))))
    576                  (incf ngpr))))
    577             (%%ff-call fpr-reloads
    578                        single-float-offset
    579                        double-float-offset
    580                        (the fixnum (-
    581                                     (ash (the fixnum
    582                                            (+ 6
    583                                               (the fixnum (logand
    584                                                            (lognot 1)
    585                                                            (the fixnum (1+ total-words))))))
    586                                          2)))
    587                        buf
    588                        entry)
    589             (ecase result-spec
    590               (:void nil)
    591               (:single-float (%get-single-float buf 8))
    592               (:double-float (%get-double-float buf 16))
    593               (:address (%get-ptr buf))
    594               (:signed-doubleword (%get-signed-long-long buf 0))
    595               (:unsigned-doubleword (%get-unsigned-long-long buf 0))
    596               (:signed-fullword (%get-signed-long buf))
    597               (:unsigned-fullword (%get-unsigned-long buf))
    598               (:signed-halfword (%get-signed-word buf 2))
    599               (:unsigned-halfword (%get-unsigned-word buf 2))
    600               (:signed-byte (%get-signed-byte buf 3))
    601               (:unsigned-byte (%get-unsigned-byte buf 3))))))))
    602   )
    603 
    604 
    605 
    606 
    607 
    608 ;;; In the PowerOpen ABI, all arguments are passed in a contiguous
    609 ;;; block.  The first 13 (!) FP args are passed in FP regs; doubleword
    610 ;;; arguments are aligned on word boundaries.
    611 #+poweropen-target
    612 (progn
    613   #+ppc32-target
    614   (progn
    615     (defun %ff-call (entry &rest specs-and-vals)
    616       (declare (dynamic-extent specs-and-vals))
    617       (let* ((len (length specs-and-vals))
    618              (total-words 0))
    619         (declare (fixnum len total-words))
    620         (unless (oddp len)
    621           (error "Length of ~s is even.  Missing result ?" specs-and-vals))
    622         (let* ((result-spec (or (car (last specs-and-vals)) :void))
    623                (nargs (ash (the fixnum (1- len)) -1))
    624                (fpr-reload-sizes (make-array 13 :element-type '(unsigned-byte 8)))
    625                (fpr-reload-offsets (make-array 13 :element-type '(unsigned-byte 16))))
    626           (declare (fixnum nargs) (dynamic-extent fpr-reload-sizes fpr-reload-offsets))
    627           (do* ((i 0 (1+ i))
    628                 (specs specs-and-vals (cddr specs))
    629                 (spec (car specs) (car specs)))
    630                ((= i nargs))
    631             (declare (fixnum i))
    632             (case spec
    633               ((:double-float :signed-doubleword :unsigned-doubleword)
    634                (incf total-words 2))
    635               ((:single-float :signed-byte :unsigned-byte :signed-halfword
    636                               :unsigned-halfword :signed-fullword
    637                               :unsigned-fullword :address)
    638                (incf total-words))
    639               (t (if (typep spec 'unsigned-byte)
    640                    (incf total-words spec)
    641                    (error "Invalid argument spec ~s" spec)))))
    642           (%stack-block ((buf (ash (logand (lognot 1) (1+ (max 6  total-words))) 2)))
    643             (do* ((i 0 (1+ i))
    644                   (fpr 0)
    645                   (offset 0 (+ offset 4))
    646                   (specs specs-and-vals (cddr specs))
    647                   (spec (car specs) (car specs))
    648                   (val (cadr specs) (cadr specs)))
    649                  ((= i nargs))
    650               (declare (fixnum i offset fpr))
    651               (case spec
    652                 (:double-float
    653                  (when (< fpr 13)
    654                    (setf (uvref fpr-reload-sizes fpr) 2
    655                          (uvref fpr-reload-offsets fpr) offset))
    656                  (incf fpr)
    657                  (setf (%get-double-float buf offset) val)
    658                  (incf offset 4))
    659                 (:single-float
    660                  (when (< fpr 13)
    661                    (setf (uvref fpr-reload-sizes fpr) 1
    662                          (uvref fpr-reload-offsets fpr) offset))
    663                  (incf fpr)
    664                  (setf (%get-single-float buf offset) val))
    665                 (:signed-doubleword
    666                  (setf (%get-signed-long-long buf offset) val)
    667                  (incf offset 4))
    668                 (:unsigned-doubleword
    669                  (setf (%get-unsigned-long-long buf offset) val)
    670                  (incf offset 4))
    671                 (:address
    672                  (setf (%get-ptr buf offset) val))
    673                 ((:unsigned-byte :unsigned-halfword :unsigned-fullword)
    674                  (setf (%get-unsigned-long buf offset) val))
    675                 (t
    676                  (if (typep spec 'unsigned-byte)
    677                    (dotimes (i spec (decf offset 4))
    678                      (setf (%get-ptr buf offset)
    679                            (%get-ptr val (* i 4)))
    680                      (incf offset 4))
    681                    (setf (%get-long buf offset) val)))))
    682             (let* ((frame-size (if (<= total-words 8)
    683                                  (ash
    684                                   (+ ppc32::c-frame.size ppc32::lisp-frame.size)
    685                                   -2)
    686                                  (+
    687                                   (ash
    688                                    (+ ppc32::c-frame.size ppc32::lisp-frame.size)
    689                                    -2)
    690                                   (logand (lognot 1)
    691                                           (1+ (- total-words 8)))))))
    692              
    693               (%%ff-call
    694                fpr-reload-sizes
    695                fpr-reload-offsets
    696                (- (logandc2 (+ frame-size 3) 3))
    697                total-words
    698                buf
    699                entry))
    700             (ecase result-spec
    701               (:void nil)
    702               (:single-float (%get-single-float buf 8))
    703               (:double-float (%get-double-float buf 16))
    704               (:address (%get-ptr buf))
    705               (:signed-doubleword (%get-signed-long-long buf 0))
    706               (:unsigned-doubleword (%get-unsigned-long-long buf 0))
    707               (:signed-fullword (%get-signed-long buf))
    708               (:unsigned-fullword (%get-unsigned-long buf))
    709               (:signed-halfword (%get-signed-word buf 2))
    710               (:unsigned-halfword (%get-unsigned-word buf 2))
    711               (:signed-byte (%get-signed-byte buf 3))
    712               (:unsigned-byte (%get-unsigned-byte buf 3)))))))
    713 
    714 
    715     (defarmlapfunction %%ff-call ((reload-sizes 8)
    716                                   (reload-offsets 4)
    717                                   (frame-size 0)                             
    718                                   (total-words arg_x)
    719                                   (buf arg_y)
    720                                   (entry arg_z))
    721       (check-nargs 6)
    722       (la imm0 12 vsp)
    723       (save-lisp-context imm0)
    724       (lwz imm0 frame-size vsp)
    725       (stwux sp sp imm0)
    726       (stw sp ppc32::c-frame.savelr sp)
    727       (macptr-ptr imm2 buf)
    728       (mov imm1 imm2)
    729       (la imm3 ppc32::c-frame.param0 sp)
    730       (li temp1 0)
    731       @copy
    732       (addi temp1 temp1 '1)
    733       (cmpw temp1 total-words)
    734       (lwz imm0 0 imm2)
    735       (la imm2 4 imm2)
    736       (stw imm0 0 imm3)
    737       (la imm3 4 imm3)
    738       (blt @copy)
    739       (lwz temp0 reload-sizes vsp)
    740       (lwz temp1 reload-offsets vsp)
    741       @load-fp1
    742       (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
    743       (cmpwi imm0 1)
    744       (lhz imm2 (+ ppc32::misc-data-offset 0) temp1)
    745       (blt @loaded)
    746       (bne @load-fp1-double)
    747       (lfsx fp1 imm1 imm2)
    748       (b @load-fp2)
    749       @load-fp1-double
    750       (lfdx fp1 imm1 imm2)
    751 
    752       @load-fp2
    753       (lbz imm0 (+ ppc32::misc-data-offset 1) temp0)
    754       (cmpwi imm0 1)
    755       (lhz imm2 (+ ppc32::misc-data-offset 2) temp1)
    756       (blt @loaded)
    757       (bne @load-fp2-double)
    758       (lfsx fp2 imm1 imm2)
    759       (b @load-fp3)
    760       @load-fp2-double
    761       (lfdx fp2 imm1 imm2)
    762 
    763       @load-fp3
    764       (lbz imm0 (+ ppc32::misc-data-offset 2) temp0)
    765       (cmpwi imm0 1)
    766       (lhz imm2 (+ ppc32::misc-data-offset 4) temp1)
    767       (blt @loaded)
    768       (bne @load-fp3-double)
    769       (lfsx fp3 imm1 imm2)
    770       (b @load-fp4)
    771       @load-fp3-double
    772       (lfdx fp3 imm1 imm2)
    773 
    774       @load-fp4
    775       (lbz imm0 (+ ppc32::misc-data-offset 3) temp0)
    776       (cmpwi imm0 1)
    777       (lhz imm2 (+ ppc32::misc-data-offset 6) temp1)
    778       (blt @loaded)
    779       (bne @load-fp4-double)
    780       (lfsx fp4 imm1 imm2)
    781       (b @load-fp5)
    782       @load-fp4-double
    783       (lfdx fp4 imm1 imm2)
    784 
    785       @load-fp5
    786       (lbz imm0 (+ ppc32::misc-data-offset 4) temp0)
    787       (cmpwi imm0 1)
    788       (lhz imm2 (+ ppc32::misc-data-offset 8) temp1)
    789       (blt @loaded)
    790       (bne @load-fp5-double)
    791       (lfsx fp5 imm1 imm2)
    792       (b @load-fp6)
    793       @load-fp5-double
    794       (lfdx fp5 imm1 imm2)
    795 
    796       @load-fp6
    797       (lbz imm0 (+ ppc32::misc-data-offset 5) temp0)
    798       (cmpwi imm0 1)
    799       (lhz imm2 (+ ppc32::misc-data-offset 10) temp1)
    800       (blt @loaded)
    801       (bne @load-fp1-double)
    802       (lfsx fp6 imm1 imm2)
    803       (b @load-fp7)
    804       @load-fp6-double
    805       (lfdx fp6 imm1 imm2)
    806 
    807       @load-fp7
    808       (lbz imm0 (+ ppc32::misc-data-offset 6) temp0)
    809       (cmpwi imm0 1)
    810       (lhz imm2 (+ ppc32::misc-data-offset 12) temp1)
    811       (blt @loaded)
    812       (bne @load-fp1-double)
    813       (lfsx fp7 imm1 imm2)
    814       (b @load-fp8)
    815       @load-fp7-double
    816       (lfdx fp7 imm1 imm2)
    817 
    818       @load-fp8
    819       (lbz imm0 (+ ppc32::misc-data-offset 7) temp0)
    820       (cmpwi imm0 1)
    821       (lhz imm2 (+ ppc32::misc-data-offset 14) temp1)
    822       (blt @loaded)
    823       (bne @load-fp8-double)
    824       (lfsx fp8 imm1 imm2)
    825       (b @load-fp9)
    826       @load-fp8-double
    827       (lfdx fp8 imm1 imm2)
    828 
    829       @load-fp9
    830       (lbz imm0 (+ ppc32::misc-data-offset 8) temp0)
    831       (cmpwi imm0 1)
    832       (lhz imm2 (+ ppc32::misc-data-offset 16) temp1)
    833       (blt @loaded)
    834       (bne @load-fp9-double)
    835       (lfsx fp9 imm1 imm2)
    836       (b @load-fp10)
    837       @load-fp9-double
    838       (lfdx fp9 imm1 imm2)
    839 
    840       @load-fp10
    841       (lbz imm0 (+ ppc32::misc-data-offset 9) temp0)
    842       (cmpwi imm0 1)
    843       (lhz imm2 (+ ppc32::misc-data-offset 18) temp1)
    844       (blt @loaded)
    845       (bne @load-fp10-double)
    846       (lfsx fp10 imm1 imm2)
    847       (b @load-fp11)
    848       @load-fp10-double
    849       (lfdx fp10 imm1 imm2)
    850 
    851       @load-fp11
    852       (lbz imm0 (+ ppc32::misc-data-offset 10) temp0)
    853       (cmpwi imm0 1)
    854       (lhz imm2 (+ ppc32::misc-data-offset 20) temp1)
    855       (blt @loaded)
    856       (bne @load-fp11-double)
    857       (lfsx fp11 imm1 imm2)
    858       (b @load-fp12)
    859       @load-fp11-double
    860       (lfdx fp11 imm1 imm2)
    861 
    862       @load-fp12
    863       (lbz imm0 (+ ppc32::misc-data-offset 11) temp0)
    864       (cmpwi imm0 1)
    865       (lhz imm2 (+ ppc32::misc-data-offset 22) temp1)
    866       (blt @loaded)
    867       (bne @load-fp12-double)
    868       (lfsx fp12 imm1 imm2)
    869       (b @load-fp13)
    870       @load-fp12-double
    871       (lfdx fp12 imm1 imm2)
    872 
    873       @load-fp13
    874       (lbz imm0 (+ ppc32::misc-data-offset 12) temp0)
    875       (cmpwi imm0 1)
    876       (lhz imm2 (+ ppc32::misc-data-offset 24) temp1)
    877       (blt @loaded)
    878       (bne @load-fp13-double)
    879       (lfsx fp13 imm1 imm2)
    880       (b @loaded)
    881       @load-fp13-double
    882       (lfdx fp13 imm1 imm2)
    883       @loaded
    884       (vpush buf)
    885       (bla .SPpoweropen-ffcall)
    886       @called
    887       (vpop buf)
    888       (macptr-ptr imm2 buf)
    889       (stw imm0 0 imm2)
    890       (stw imm1 4 imm2)
    891       (stfs fp1 8 imm2)
    892       (stfd fp1 16 imm2)
    893       (restore-full-lisp-context)
    894       (li arg_z (target-nil-value))
    895       (bx lr))
    896     )
    897 
    898   #+ppc64-target
    899   (progn
    900   ;;; There are a few funky, non-obvious things going on here.
    901   ;;; The main %FF-CALL function uses WITH-VARIABLE-C-FRAME;
    902   ;;; the compiler will generate code to pop that frame off
    903   ;;; of the C/control stack, but the subprim that implements
    904   ;;; %ff-call has already popped it off.  To put things back
    905   ;;; in balance, the LAP function %%FF-RESULT pushes an
    906   ;;; extra frame on the cstack.
    907   ;;; %FF-CALL calls %%FF-RESULT to box the result, which may
    908   ;;; be in r3/imm0 or in fp1.  It's critical that the call
    909   ;;; to %%FF-RESULT not be compiled as "multiple-value returning",
    910   ;;; since the MV machinery may clobber IMM0.
    911     (defarmlapfunction %%ff-result ((spec arg_z))
    912       (stdu sp -160 sp)
    913       (ld arg_y ':void nfn)
    914       (cmpd cr0 spec arg_y)
    915       (ld arg_x ':address nfn)
    916       (cmpd cr1 spec arg_x)
    917       (ld temp3 ':single-float nfn)
    918       (cmpd cr2 spec temp3)
    919       (ld arg_y ':double-float nfn)
    920       (cmpd cr3 spec arg_y)
    921       (ld arg_x ':unsigned-doubleword nfn)
    922       (cmpd cr4 spec arg_x)
    923       (ld temp3 ':signed-doubleword nfn)
    924       (cmpd cr5 spec temp3)
    925       (beq cr0 @void)
    926       (beq cr1 @address)
    927       (beq cr2 @single-float)
    928       (beq cr3 @double-float)
    929       (beq cr4 @unsigned-doubleword)
    930       (beq cr5 @signed-doubleword)
    931       (box-fixnum arg_z imm0)
    932       (bx lr)
    933       @void
    934       (li arg_z nil)
    935       (bx lr)
    936       @address
    937       (li imm1 ppc64::macptr-header)
    938       (subi allocptr allocptr (- ppc64::macptr.size ppc64::fulltag-misc))
    939       (tdlt allocptr allocbase)
    940       (std imm1 ppc64::misc-header-offset allocptr)
    941       (mov arg_z allocptr)
    942       (clrrdi allocptr allocptr 4)
    943       (std imm0 ppc64::macptr.address arg_z)
    944       (bx lr)
    945       @single-float
    946       (put-single-float fp1 arg_z)
    947       (bx lr)
    948       @double-float
    949       (li imm1 ppc64::double-float-header)
    950       (subi allocptr allocptr (- ppc64::double-float.size ppc64::fulltag-misc))
    951       (tdlt allocptr allocbase)
    952       (std imm1 ppc64::misc-header-offset allocptr)
    953       (mov arg_z allocptr)
    954       (clrrdi allocptr allocptr 4)
    955       (stfd fp1 ppc64::macptr.address arg_z)
    956       (bx lr)
    957       @unsigned-doubleword
    958       (ba .SPmakeu64)
    959       @signed-doubleword
    960       (ba .SPmakes64))
    961 
    962   ;;; This is just here so that we can jump to a subprim from lisp.
    963     (defarmlapfunction %do-ff-call ((regbuf arg_y) (entry arg_z))
    964       (cmpdi cr0 regbuf nil)
    965       (bnea cr0 .SPpoweropen-ffcall-return-registers)
    966       (ba .SPpoweropen-ffcall))
    967  
    968     (defun %ff-call (entry &rest specs-and-vals)
    969       (declare (dynamic-extent specs-and-vals))
    970       (let* ((len (length specs-and-vals))
    971              (total-words 0)
    972              (registers nil))
    973         (declare (fixnum len total-words))
    974         (let* ((result-spec (or (car (last specs-and-vals)) :void))
    975                (nargs (ash (the fixnum (1- len)) -1)))
    976           (declare (fixnum nargs))
    977           (ecase result-spec
    978             ((:address :unsigned-doubleword :signed-doubleword
    979                        :single-float :double-float
    980                        :signed-fullword :unsigned-fullword
    981                        :signed-halfword :unsigned-halfword
    982                        :signed-byte :unsigned-byte
    983                        :void)
    984              (do* ((i 0 (1+ i))
    985                    (specs specs-and-vals (cddr specs))
    986                    (spec (car specs) (car specs)))
    987                   ((= i nargs))
    988                (declare (fixnum i))
    989                (case spec
    990                  (:registers nil)
    991                  ((:address :unsigned-doubleword :signed-doubleword
    992                             :single-float :double-float
    993                             :signed-fullword :unsigned-fullword
    994                             :signed-halfword :unsigned-halfword
    995                             :signed-byte :unsigned-byte
    996                             :hybrid-int-float :hybrid-float-float
    997                             :hybrid-float-int)
    998                   (incf total-words))
    999                  (t (if (typep spec 'unsigned-byte)
    1000                       (incf total-words spec)
    1001                       (error "unknown arg spec ~s" spec)))))
    1002              (%stack-block ((fp-args (* 13 8)))
    1003                (with-variable-c-frame
    1004                    total-words frame
    1005                    (with-macptrs ((argptr))
     309(defun %ff-call (entry &rest specs-and-vals)
     310  (declare (dynamic-extent specs-and-vals))
     311  (let* ((len (length specs-and-vals))
     312         (total-words 0))
     313    (declare (fixnum len total-words))
     314    (let* ((result-spec (or (car (last specs-and-vals)) :void))
     315           (nargs (ash (the fixnum (1- len)) -1)))
     316      (declare (fixnum nargs))
     317      (ecase result-spec
     318        ((:address :unsigned-doubleword :signed-doubleword
     319                   :single-float :double-float
     320                   :signed-fullword :unsigned-fullword
     321                   :signed-halfword :unsigned-halfword
     322                   :signed-byte :unsigned-byte
     323                   :void)
     324         (do* ((i 0 (1+ i))
     325               (specs specs-and-vals (cddr specs))
     326               (spec (car specs) (car specs)))
     327              ((= i nargs))
     328           (declare (fixnum i))
     329           (case spec
     330             ((:address :single-float
     331                        :signed-fullword :unsigned-fullword
     332                        :signed-halfword :unsigned-halfword
     333                        :signed-byte :unsigned-byte)
     334              (incf total-words))
     335             ((:double-float :unsigned-doubleword :signed-doubleword)
     336              (setq total-words (+ total-words (logand total-words 1)))
     337              (incf total-words 2))
     338
     339             (t (if (typep spec 'unsigned-byte)
     340                  (incf total-words spec)
     341                  (error "unknown arg spec ~s" spec)))))
     342         ;; It's necessary to ensure that the C frame is the youngest thing on
     343         ;; the foreign stack here.
     344         (let* ((tag (cons nil nil)))
     345           (declare (dynamic-extent tag))
     346           (%stack-block ((result 8))
     347             (catch tag
     348               (with-macptrs ((argptr))
     349                 (with-variable-c-frame
     350                     total-words frame
    1006351                     (%setf-macptr-to-object argptr frame)
    1007                      (let* ((offset ppc64::c-frame.param0)
    1008                             (n-fp-args 0))
    1009                        (declare (fixnum offset n-fp-args))
     352                     (let* ((arg-offset 8))
     353                       (declare (fixnum arg-offset))
    1010354                       (do* ((i 0 (1+ i))
    1011355                             (specs specs-and-vals (cddr specs))
     
    1015359                         (declare (fixnum i))
    1016360                         (case spec
    1017                            (:registers (setq registers val))
    1018                            (:address (setf (%get-ptr argptr offset) val)
    1019                                      (incf offset 8))
    1020                            ((:signed-doubleword :signed-fullword :signed-halfword
    1021                                                 :signed-byte)
    1022                          
    1023                             (setf (%%get-signed-longlong argptr offset) val)
    1024                             (incf offset 8))
    1025                            ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword
    1026                                                   :unsigned-byte)
    1027                             (setf (%%get-unsigned-longlong argptr offset) val)
    1028                             (incf offset 8))
    1029                            (:hybrid-int-float
    1030                             (setf (%%get-unsigned-longlong argptr offset) val)
    1031                             (when (< n-fp-args 13)
    1032                               (setf (%get-double-float fp-args (* n-fp-args 8))
    1033                                     (%double-float (%get-single-float argptr (+ offset 4)))))
    1034                             (incf n-fp-args)
    1035                             (incf offset 8))
    1036                            (:hybrid-float-int
    1037                             (setf (%%get-unsigned-longlong argptr offset) val)
    1038                             (when (< n-fp-args 13)
    1039                               (setf (%get-double-float fp-args (* n-fp-args 8))
    1040                                     (%double-float (%get-single-float argptr offset))))
    1041                             (incf n-fp-args)
    1042                             (incf offset 8))
    1043                            (:hybrid-float-float
    1044                             (setf (%%get-unsigned-longlong argptr offset) val)
    1045                             (when (< n-fp-args 13)
    1046                               (setf (%get-double-float fp-args (* n-fp-args 8))
    1047                                     (%double-float (%get-single-float argptr offset))))
    1048                             (incf n-fp-args)
    1049                             (when (< n-fp-args 13)
    1050                               (setf (%get-double-float fp-args (* n-fp-args 8))
    1051                                     (%double-float (%get-single-float argptr (+ offset 4)))))
    1052                             (incf n-fp-args)
    1053                             (incf offset 8))
     361                           (:address
     362                            (setf (%get-ptr argptr arg-offset) val)
     363                            (incf arg-offset 4))
     364                           (:signed-doubleword
     365                            (when (logtest 7 arg-offset)
     366                              (incf arg-offset 4))
     367                            (setf (%%get-signed-longlong argptr arg-offset) val)
     368                            (incf arg-offset 8))
     369                           ((:signed-fullword :signed-halfword :signed-byte)
     370                            (setf (%get-signed-long argptr arg-offset) val)
     371                            (incf arg-offset 4))
     372                           (:unsigned-doubleword
     373                             (when (logtest 7 arg-offset)
     374                               (incf arg-offset 4))
     375                             (setf (%%get-unsigned-longlong argptr arg-offset) val)
     376                             (incf arg-offset 8))
     377                           ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
     378                            (setf (%get-unsigned-long argptr arg-offset) val)
     379                            (incf arg-offset 4))
    1054380                           (:double-float
    1055                             (setf (%get-double-float argptr offset) val)
    1056                             (when (< n-fp-args 13)
    1057                               (setf (%get-double-float fp-args (* n-fp-args 8)) val))
    1058                             (incf n-fp-args)
    1059                             (incf offset 8))
     381                            (when (logtest 7 arg-offset)
     382                              (incf arg-offset 4))
     383                            (setf (%get-double-float argptr arg-offset) val)
     384                            (incf arg-offset 8))
    1060385                           (:single-float
    1061                             (setf (%get-single-float argptr offset) val)
    1062                             (when (< n-fp-args 13)
    1063                               (setf (%get-double-float fp-args (* n-fp-args 8))
    1064                                     (%double-float val)))
    1065                             (incf n-fp-args)
    1066                             (incf offset 8))
     386                            (setf (%get-single-float argptr arg-offset) val)
     387                            (incf arg-offset 4))
    1067388                           (t
    1068                             (let* ((p 0))
    1069                               (declare (fixnum p))
    1070                               (dotimes (i (the fixnum spec))
    1071                                 (setf (%get-ptr argptr offset) (%get-ptr val p))
    1072                                 (incf p 8)
    1073                                 (incf offset 8))))))
    1074                        (%load-fp-arg-regs n-fp-args fp-args)
    1075                        (%do-ff-call registers entry)
    1076                        (values (%%ff-result result-spec)))))))))))
    1077 
    1078     )
    1079   )
    1080 )
     389                              (let* ((p 0))
     390                                (declare (fixnum p))
     391                                (dotimes (i (the fixnum spec))
     392                                  (setf (%get-ptr argptr arg-offset) (%get-ptr val p))
     393                                  (incf p 4)
     394                                  (incf arg-offset 4)))))))
     395                         (%do-ff-call tag result entry))))
     396             (ecase result-spec
     397               (:void nil)
     398               (:address (%get-ptr result 0))
     399               (:unsigned-byte (%get-unsigned-byte result 0))
     400               (:signed-byte (%get-signed-byte result 0))
     401               (:unsigned-halfword (%get-unsigned-word result 0))
     402               (:signed-halfword (%get-signed-word result 0))
     403               (:unsigned-fullword (%get-unsigned-long result 0))
     404               (:signed-fullword (%get-signed-long result 0))
     405               (:unsigned-doubleword (%get-natural result 0))
     406               (:signed-doubleword (%get-signed-natural result 0))
     407               (:single-float (%get-single-float result 0))
     408               (:double-float (%get-double-float result 0))))))))))
    1081409
    1082410
Note: See TracChangeset for help on using the changeset viewer.