Context Navigation

← Previous Changeset
Next Changeset →

Changeset 14159

Timestamp:

Aug 9, 2010, 3:31:00 AM (14 years ago)

Author:

Gary Byers

Message:

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

Location:

trunk/source

Files:

: 3 edited

compiler/ARM/arm-vinsns.lisp (modified) (2 diffs)
compiler/ARM/arm2.lisp (modified) (1 diff)
level-0/ARM/arm-def.lisp (modified) (2 diffs)

Legend:

: Unmodified
: Added
: Removed

trunk/source/compiler/ARM/arm-vinsns.lisp

-              r14119
+              r14159
   (str prevsp (:@ sp (:$ 4))))
 (define-arm-vinsn (alloc-variable-c-frame :predicatable)
+(define-arm-vinsn (alloc-variable-eabi-c-frame :predicatable)
     (()
      ((n-c-args :lisp))
 …
       (size :imm)
       (prevsp :imm)))
   (add size n-c-args (:$ (ash (+ 4 1) arm::word-shift)))
+  (add size n-c-args (:$ (ash (+ 4 4 1) arm::word-shift)))
   (bic size size (:$ arm::fixnumone))
   (add size size (:$ arm::fixnumone))

trunk/source/compiler/ARM/arm2.lisp

-              r14119
+              r14159
   (let* ((reg (arm2-one-untargeted-reg-form seg size arm::arg_z)))
     (ecase (backend-name *target-backend*)
+      (:linuxarm32 (! alloc-variable-eabi-c-frame reg))
+      ((:darwinarm32 :darwinarm64 :linuxarm64) (! alloc-variable-c-frame reg)))
+      (:linuxarm (! alloc-variable-eabi-c-frame reg)))
     (arm2-open-undo $undo-arm-c-frame)
     (arm2-undo-body seg vreg xfer body old-stack)))

trunk/source/level-0/ARM/arm-def.lisp

-              r14119
+              r14159
   (return-lisp-frame))
+#+notyet
+(progn
+;;; FF-call, in LAP.
+#+eabi-target
+(progn
+  (defarmlapfunction %%ff-call ((fploads 8)
+                                (single-offset 4)
+                                (double-offset 0)
+                                (framesize arg_x) ;always even, negative, includes frame overhead
+                                (buf arg_y)
+                                (entry arg_z))
+    (check-nargs 6)
+    (la imm0 12 vsp)
+    (save-lisp-context imm0)
+    (stwux sp sp framesize)
+    (stw sp 4 sp)
+    (macptr-ptr imm2 buf)
+    (mov imm1 imm2)
+    (la imm3 ppc32::eabi-c-frame.param0 sp)
+    (li imm0 0)
+    (lwz temp1 single-offset vsp)
+    (lwz temp2 double-offset vsp)
+    @copy
+    (addi imm0 imm0 8)
+    (cmpw imm0 temp1)
+    (lfd fp0 0 imm2)
+    (la imm2 8 imm2)
+    (stfd fp0 0 imm3)
+    (la imm3 8 imm3)
+    (blt @copy)
+    ;; We've copied the gpr-save area and the "other" arg words.
+    ;; Sadly, we may still need to load up to 8 FPRs, and we have
+    ;; to use some pretty ugly code to do so.
+    (add temp1 temp1 imm1)
+    (add temp2 temp2 imm1)
+    (lwz temp0 fploads vsp)
+    @load-fp1
+    (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
+    (cmpwi imm0 1)
+    (blt @loaded)
+    (bne @load-fp1-double)
+    (lfs fp1 0 temp1)
+    (la temp1 4 temp1)
+    (b @load-fp2)
+    @load-fp1-double
+    (lfd fp1 0 temp2)
+    (la temp2 8 temp2)
+    @load-fp2
+    (lbz imm0 (+ ppc32::misc-data-offset 1) temp0)
+    (cmpwi imm0 1)
+    (blt @loaded)
+    (bne @load-fp2-double)
+    (lfs fp2 0 temp1)
+    (la temp1 4 temp1)
+    (b @load-fp3)
+    @load-fp2-double
+    (lfd fp2 0 temp2)
+    (la temp2 8 temp2)
+    @load-fp3
+    (lbz imm0 (+ ppc32::misc-data-offset 2) temp0)
+    (cmpwi imm0 1)
+    (blt @loaded)
+    (bne @load-fp3-double)
+    (lfs fp3 0 temp1)
+    (la temp1 4 temp1)
+    (b @load-fp4)
+    @load-fp3-double
+    (lfd fp3 0 temp2)
+    (la temp2 8 temp2)
+    @load-fp4
+    (lbz imm0 (+ ppc32::misc-data-offset 3) temp0)
+    (cmpwi imm0 1)
+    (blt @loaded)
+    (bne @load-fp4-double)
+    (lfs fp4 0 temp1)
+    (la temp1 4 temp1)
+    (b @load-fp5)
+    @load-fp4-double
+    (lfd fp4 0 temp2)
+    (la temp2 8 temp2)
+    @load-fp5
+    (lbz imm0 (+ ppc32::misc-data-offset 4) temp0)
+    (cmpwi imm0 1)
+    (blt @loaded)
+    (bne @load-fp5-double)
+    (lfs fp5 0 temp1)
+    (la temp1 4 temp1)
+    (b @load-fp6)
+    @load-fp5-double
+    (lfd fp5 0 temp2)
+    (la temp2 8 temp2)
+    @load-fp6
+    (lbz imm0 (+ ppc32::misc-data-offset 5) temp0)
+    (cmpwi imm0 1)
+    (blt @loaded)
+    (bne @load-fp6-double)
+    (lfs fp6 0 temp1)
+    (la temp1 4 temp1)
+    (b @load-fp7)
+    @load-fp6-double
+    (lfd fp6 0 temp2)
+    (la temp2 8 temp2)
+    @load-fp7
+    (lbz imm0 (+ ppc32::misc-data-offset 6) temp0)
+    (cmpwi imm0 1)
+    (blt @loaded)
+    (bne @load-fp7-double)
+    (lfs fp7 0 temp1)
+    (la temp1 4 temp1)
+    (b @load-fp8)
+    @load-fp7-double
+    (lfd fp7 0 temp2)
+    (la temp2 8 temp2)
+    @load-fp8
+    (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
+    (cmpwi imm0 1)
+    (blt @loaded)
+    (bne @load-fp8-double)
+    (lfs fp8 0 temp1)
+    (b @loaded)
+    @load-fp8-double
+    (lfd fp8 0 temp2)
+    @loaded
+    (vpush buf)
+    (bla .SPeabi-ff-call)
+    (vpop buf)
+    (macptr-ptr imm2 buf)
+    (stw imm0 0 imm2)
+    (stw imm1 4 imm2)
+    (stfs fp1 8 imm2)
+    (stfd fp1 16 imm2)
+    (restore-full-lisp-context)
+    (li arg_z (target-nil-value))
+    (bx lr))
+(defarmlapfunction %do-ff-call ((tag arg_x) (result arg_y) (entry arg_z))
+  (stmdb (:! vsp) (tag result))
+  (bla .SPeabi-ff-call)
+  (ldmia (:! vsp) (tag result))
+  (macptr-ptr imm2 result)
+  (str imm0 (:@ imm2 (:$ 0)))
+  (str imm1 (:@ imm2 (:$ 4)))
+  (vpush1 tag)
+  (mov arg_z 'nil)
+  (vpush1 arg_z)
+  (set-nargs 1)
+  (bla .SPthrow))
+  (defun %ff-call (entry &rest specs-and-vals)
+    "Call the foreign function at address entrypoint passing the values of
+each arg as a foreign argument of type indicated by the corresponding
+arg-type-keyword. Returns the foreign function result (coerced to a Lisp
+object of type indicated by result-type-keyword), or NIL if
+result-type-keyword is :VOID or NIL"
+    (declare (dynamic-extent specs-and-vals))
+    (let* ((len (length specs-and-vals))
+           (other-offset 8)
+           (single-float-offset 8)
+           (double-float-offset 0)
+           (nsingle-floats 0)
+           (ndouble-floats 0)
+           (nother-words 0)
+           (nfpr-args 0)
+           (ngpr-args 0))
+      (declare (fixnum len  other-offset single-float-offset double-float-offset
+                       nsingle-floats ndouble-floats nother-words nfpr-args ngpr-args))
+      (unless (oddp len)
+        (error "Length of ~s is even.  Missing result ?" specs-and-vals))
+      (let* ((result-spec (or (car (last specs-and-vals)) :void))
+             (nargs (ash (the fixnum (1- len)) -1))
+             (fpr-reloads (make-array 8 :element-type '(unsigned-byte 8))))
+        (declare (fixnum nargs) (dynamic-extent fpr-reloads))
+        (do* ((i 0 (1+ i))
+              (specs specs-and-vals (cddr specs))
+              (spec (car specs) (car specs)))
+             ((= i nargs))
+          (declare (fixnum i))
+          (ecase spec
+            (:double-float (incf nfpr-args)
+                           (if (<= nfpr-args 8)
+                             (incf ndouble-floats)
+                             (progn
+                               (if (oddp nother-words)
+                                 (incf nother-words))
+                               (incf nother-words 2))))
+            (:single-float (incf nfpr-args)
+                           (if (<= nfpr-args 8)
+                             (incf nsingle-floats)
+                             (incf nother-words)))
+            ((:signed-doubleword :unsigned-doubleword)
+             (if (oddp ngpr-args)
+               (incf ngpr-args))
+             (incf ngpr-args 2)
+             (when (> ngpr-args 8)
+               (if (oddp nother-words)
+                 (incf nother-words))
+               (incf nother-words 2)))
+            ((:signed-byte :unsigned-byte :signed-halfword :unsigned-halfword
+                           :signed-fullword :unsigned-fullword :address)
+             (incf ngpr-args)
+             (if (> ngpr-args 8)
+               (incf nother-words)))))
+        (let* ((single-words (+ 8 nother-words nsingle-floats))
+               (total-words (if (zerop ndouble-floats)
+                              single-words
+                              (+ (the fixnum (+ ndouble-floats ndouble-floats))
+                                 (the fixnum (logand (lognot 1)
+                                                     (the fixnum (1+ single-words))))))))
+          (declare (fixnum total-words single-words))
+          (%stack-block
+              ((buf (ash total-words 2)))
+            (setq single-float-offset (+ other-offset nother-words))
+            (setq double-float-offset
+                  (logand (lognot 1)
+                          (the fixnum (1+ (the fixnum (+ single-float-offset nsingle-floats))))))
+           ;;; Make another pass through the arg/value pairs, evaluating each arg into
+           ;;; the buffer.
+            (do* ((i 0 (1+ i))
+                  (specs specs-and-vals (cddr specs))
+                  (spec (car specs) (car specs))
+                  (val (cadr specs) (cadr specs))
+                  (ngpr 0)
+                  (nfpr 0)
+                  (gpr-byte-offset 0)
+                  (other-byte-offset (ash other-offset 2))
+                  (single-byte-offset (ash single-float-offset 2))
+                  (double-byte-offset (ash double-float-offset 2)))
+                 ((= i nargs))
+              (declare (fixnum i gpr-byte-offset single-byte-offset double-byte-offset
+                               ngpr nfpr))
+              (case spec
+                (:double-float
+                 (cond ((< nfpr 8)
+                        (setf (uvref fpr-reloads nfpr) 2
+                              (%get-double-float buf double-byte-offset) val
+                              double-byte-offset (+ double-byte-offset 8)))
+                       (t
+                        (setq other-byte-offset (logand (lognot 7)
+                                                        (the fixnum (+ other-byte-offset 4))))
+                        (setf (%get-double-float buf other-byte-offset) val)
+                        (setq other-byte-offset (+ other-byte-offset 8))))
+                 (incf nfpr))
+                (:single-float
+                 (cond ((< nfpr 8)
+                        (setf (uvref fpr-reloads nfpr) 1
+                              (%get-single-float buf single-byte-offset) val
+                              single-byte-offset (+ single-byte-offset 4)))
+                       (t
+                        (setf (%get-single-float buf other-byte-offset) val
+                              other-byte-offset (+ other-byte-offset 4))))
+                 (incf nfpr))
+                (:address
+                 (cond ((< ngpr 8)
+                        (setf (%get-ptr buf gpr-byte-offset) val
+                              gpr-byte-offset (+ gpr-byte-offset 4)))
+                       (t
+                        (setf (%get-ptr buf other-byte-offset) val
+                              other-byte-offset (+ other-byte-offset 4))))
+                 (incf ngpr))
+                ((:signed-doubleword :unsigned-doubleword)
+                 (when (oddp ngpr)
+                   (incf ngpr)
+                   (incf gpr-byte-offset 4))
+                 (cond ((< ngpr 8)
+                        (if (eq spec :signed-doubleword)
+                          (setf (%get-signed-long-long buf gpr-byte-offset) val)
+                          (setf (%get-unsigned-long-long buf gpr-byte-offset) val))
+                        (incf gpr-byte-offset 8))
+                       (t
+                        (when (logtest other-byte-offset 7)
+                          (incf other-byte-offset 4))
+                        (if (eq spec :signed-doubleword)
+                          (setf (%get-signed-long-long buf other-byte-offset) val)
+                          (setf (%get-unsigned-long-long buf other-byte-offset) val))
+                        (incf other-byte-offset 8)))
+                 (incf ngpr 2))
+                ((:unsigned-byte :unsigned-halfword :unsigned-fullword)
+                 (cond ((< ngpr 8)
+                        (setf (%get-unsigned-long buf gpr-byte-offset) val
+                              gpr-byte-offset (+ gpr-byte-offset 4)))
+                       (t
+                        (setf (%get-unsigned-long buf other-byte-offset) val
+                              other-byte-offset (+ other-byte-offset 4))))
+                 (incf ngpr))
+                (t
+                 (cond ((< ngpr 8)
+                        (setf (%get-long buf gpr-byte-offset) val
+                              gpr-byte-offset (+ gpr-byte-offset 4)))
+                       (t
+                        (setf (%get-long buf other-byte-offset) val
+                              other-byte-offset (+ other-byte-offset 4))))
+                 (incf ngpr))))
+            (%%ff-call fpr-reloads
+                       single-float-offset
+                       double-float-offset
+                       (the fixnum (-
+                                    (ash (the fixnum
+                                           (+ 6
+                                              (the fixnum (logand
+                                                           (lognot 1)
+                                                           (the fixnum (1+ total-words))))))
+)))
+                       buf
+                       entry)
+            (ecase result-spec
+              (:void nil)
+              (:single-float (%get-single-float buf 8))
+              (:double-float (%get-double-float buf 16))
+              (:address (%get-ptr buf))
+              (:signed-doubleword (%get-signed-long-long buf 0))
+              (:unsigned-doubleword (%get-unsigned-long-long buf 0))
+              (:signed-fullword (%get-signed-long buf))
+              (:unsigned-fullword (%get-unsigned-long buf))
+              (:signed-halfword (%get-signed-word buf 2))
+              (:unsigned-halfword (%get-unsigned-word buf 2))
+              (:signed-byte (%get-signed-byte buf 3))
+              (:unsigned-byte (%get-unsigned-byte buf 3))))))))
+  )
+;;; In the PowerOpen ABI, all arguments are passed in a contiguous
+;;; block.  The first 13 (!) FP args are passed in FP regs; doubleword
+;;; arguments are aligned on word boundaries.
+#+poweropen-target
+(progn
+  #+ppc32-target
+  (progn
+    (defun %ff-call (entry &rest specs-and-vals)
+      (declare (dynamic-extent specs-and-vals))
+      (let* ((len (length specs-and-vals))
+             (total-words 0))
+        (declare (fixnum len total-words))
+        (unless (oddp len)
+          (error "Length of ~s is even.  Missing result ?" specs-and-vals))
+        (let* ((result-spec (or (car (last specs-and-vals)) :void))
+               (nargs (ash (the fixnum (1- len)) -1))
+               (fpr-reload-sizes (make-array 13 :element-type '(unsigned-byte 8)))
+               (fpr-reload-offsets (make-array 13 :element-type '(unsigned-byte 16))))
+          (declare (fixnum nargs) (dynamic-extent fpr-reload-sizes fpr-reload-offsets))
+          (do* ((i 0 (1+ i))
+                (specs specs-and-vals (cddr specs))
+                (spec (car specs) (car specs)))
+               ((= i nargs))
+            (declare (fixnum i))
+            (case spec
+              ((:double-float :signed-doubleword :unsigned-doubleword)
+               (incf total-words 2))
+              ((:single-float :signed-byte :unsigned-byte :signed-halfword
+                              :unsigned-halfword :signed-fullword
+                              :unsigned-fullword :address)
+               (incf total-words))
+              (t (if (typep spec 'unsigned-byte)
+                   (incf total-words spec)
+                   (error "Invalid argument spec ~s" spec)))))
+          (%stack-block ((buf (ash (logand (lognot 1) (1+ (max 6  total-words))) 2)))
+            (do* ((i 0 (1+ i))
+                  (fpr 0)
+                  (offset 0 (+ offset 4))
+                  (specs specs-and-vals (cddr specs))
+                  (spec (car specs) (car specs))
+                  (val (cadr specs) (cadr specs)))
+                 ((= i nargs))
+              (declare (fixnum i offset fpr))
+              (case spec
+                (:double-float
+                 (when (< fpr 13)
+                   (setf (uvref fpr-reload-sizes fpr) 2
+                         (uvref fpr-reload-offsets fpr) offset))
+                 (incf fpr)
+                 (setf (%get-double-float buf offset) val)
+                 (incf offset 4))
+                (:single-float
+                 (when (< fpr 13)
+                   (setf (uvref fpr-reload-sizes fpr) 1
+                         (uvref fpr-reload-offsets fpr) offset))
+                 (incf fpr)
+                 (setf (%get-single-float buf offset) val))
+                (:signed-doubleword
+                 (setf (%get-signed-long-long buf offset) val)
+                 (incf offset 4))
+                (:unsigned-doubleword
+                 (setf (%get-unsigned-long-long buf offset) val)
+                 (incf offset 4))
+                (:address
+                 (setf (%get-ptr buf offset) val))
+                ((:unsigned-byte :unsigned-halfword :unsigned-fullword)
+                 (setf (%get-unsigned-long buf offset) val))
+                (t
+                 (if (typep spec 'unsigned-byte)
+                   (dotimes (i spec (decf offset 4))
+                     (setf (%get-ptr buf offset)
+                           (%get-ptr val (* i 4)))
+                     (incf offset 4))
+                   (setf (%get-long buf offset) val)))))
+            (let* ((frame-size (if (<= total-words 8)
+                                 (ash
+                                  (+ ppc32::c-frame.size ppc32::lisp-frame.size)
+                                  -2)
+                                 (+
+                                  (ash
+                                   (+ ppc32::c-frame.size ppc32::lisp-frame.size)
+                                   -2)
+                                  (logand (lognot 1)
+                                          (1+ (- total-words 8)))))))
+              (%%ff-call
+               fpr-reload-sizes
+               fpr-reload-offsets
+               (- (logandc2 (+ frame-size 3) 3))
+               total-words
+               buf
+               entry))
+            (ecase result-spec
+              (:void nil)
+              (:single-float (%get-single-float buf 8))
+              (:double-float (%get-double-float buf 16))
+              (:address (%get-ptr buf))
+              (:signed-doubleword (%get-signed-long-long buf 0))
+              (:unsigned-doubleword (%get-unsigned-long-long buf 0))
+              (:signed-fullword (%get-signed-long buf))
+              (:unsigned-fullword (%get-unsigned-long buf))
+              (:signed-halfword (%get-signed-word buf 2))
+              (:unsigned-halfword (%get-unsigned-word buf 2))
+              (:signed-byte (%get-signed-byte buf 3))
+              (:unsigned-byte (%get-unsigned-byte buf 3)))))))
+    (defarmlapfunction %%ff-call ((reload-sizes 8)
+                                  (reload-offsets 4)
+                                  (frame-size 0)
+                                  (total-words arg_x)
+                                  (buf arg_y)
+                                  (entry arg_z))
+      (check-nargs 6)
+      (la imm0 12 vsp)
+      (save-lisp-context imm0)
+      (lwz imm0 frame-size vsp)
+      (stwux sp sp imm0)
+      (stw sp ppc32::c-frame.savelr sp)
+      (macptr-ptr imm2 buf)
+      (mov imm1 imm2)
+      (la imm3 ppc32::c-frame.param0 sp)
+      (li temp1 0)
+      @copy
+      (addi temp1 temp1 '1)
+      (cmpw temp1 total-words)
+      (lwz imm0 0 imm2)
+      (la imm2 4 imm2)
+      (stw imm0 0 imm3)
+      (la imm3 4 imm3)
+      (blt @copy)
+      (lwz temp0 reload-sizes vsp)
+      (lwz temp1 reload-offsets vsp)
+      @load-fp1
+      (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 0) temp1)
+      (blt @loaded)
+      (bne @load-fp1-double)
+      (lfsx fp1 imm1 imm2)
+      (b @load-fp2)
+      @load-fp1-double
+      (lfdx fp1 imm1 imm2)
+      @load-fp2
+      (lbz imm0 (+ ppc32::misc-data-offset 1) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 2) temp1)
+      (blt @loaded)
+      (bne @load-fp2-double)
+      (lfsx fp2 imm1 imm2)
+      (b @load-fp3)
+      @load-fp2-double
+      (lfdx fp2 imm1 imm2)
+      @load-fp3
+      (lbz imm0 (+ ppc32::misc-data-offset 2) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 4) temp1)
+      (blt @loaded)
+      (bne @load-fp3-double)
+      (lfsx fp3 imm1 imm2)
+      (b @load-fp4)
+      @load-fp3-double
+      (lfdx fp3 imm1 imm2)
+      @load-fp4
+      (lbz imm0 (+ ppc32::misc-data-offset 3) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 6) temp1)
+      (blt @loaded)
+      (bne @load-fp4-double)
+      (lfsx fp4 imm1 imm2)
+      (b @load-fp5)
+      @load-fp4-double
+      (lfdx fp4 imm1 imm2)
+      @load-fp5
+      (lbz imm0 (+ ppc32::misc-data-offset 4) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 8) temp1)
+      (blt @loaded)
+      (bne @load-fp5-double)
+      (lfsx fp5 imm1 imm2)
+      (b @load-fp6)
+      @load-fp5-double
+      (lfdx fp5 imm1 imm2)
+      @load-fp6
+      (lbz imm0 (+ ppc32::misc-data-offset 5) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 10) temp1)
+      (blt @loaded)
+      (bne @load-fp1-double)
+      (lfsx fp6 imm1 imm2)
+      (b @load-fp7)
+      @load-fp6-double
+      (lfdx fp6 imm1 imm2)
+      @load-fp7
+      (lbz imm0 (+ ppc32::misc-data-offset 6) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 12) temp1)
+      (blt @loaded)
+      (bne @load-fp1-double)
+      (lfsx fp7 imm1 imm2)
+      (b @load-fp8)
+      @load-fp7-double
+      (lfdx fp7 imm1 imm2)
+      @load-fp8
+      (lbz imm0 (+ ppc32::misc-data-offset 7) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 14) temp1)
+      (blt @loaded)
+      (bne @load-fp8-double)
+      (lfsx fp8 imm1 imm2)
+      (b @load-fp9)
+      @load-fp8-double
+      (lfdx fp8 imm1 imm2)
+      @load-fp9
+      (lbz imm0 (+ ppc32::misc-data-offset 8) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 16) temp1)
+      (blt @loaded)
+      (bne @load-fp9-double)
+      (lfsx fp9 imm1 imm2)
+      (b @load-fp10)
+      @load-fp9-double
+      (lfdx fp9 imm1 imm2)
+      @load-fp10
+      (lbz imm0 (+ ppc32::misc-data-offset 9) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 18) temp1)
+      (blt @loaded)
+      (bne @load-fp10-double)
+      (lfsx fp10 imm1 imm2)
+      (b @load-fp11)
+      @load-fp10-double
+      (lfdx fp10 imm1 imm2)
+      @load-fp11
+      (lbz imm0 (+ ppc32::misc-data-offset 10) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 20) temp1)
+      (blt @loaded)
+      (bne @load-fp11-double)
+      (lfsx fp11 imm1 imm2)
+      (b @load-fp12)
+      @load-fp11-double
+      (lfdx fp11 imm1 imm2)
+      @load-fp12
+      (lbz imm0 (+ ppc32::misc-data-offset 11) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 22) temp1)
+      (blt @loaded)
+      (bne @load-fp12-double)
+      (lfsx fp12 imm1 imm2)
+      (b @load-fp13)
+      @load-fp12-double
+      (lfdx fp12 imm1 imm2)
+      @load-fp13
+      (lbz imm0 (+ ppc32::misc-data-offset 12) temp0)
+      (cmpwi imm0 1)
+      (lhz imm2 (+ ppc32::misc-data-offset 24) temp1)
+      (blt @loaded)
+      (bne @load-fp13-double)
+      (lfsx fp13 imm1 imm2)
+      (b @loaded)
+      @load-fp13-double
+      (lfdx fp13 imm1 imm2)
+      @loaded
+      (vpush buf)
+      (bla .SPpoweropen-ffcall)
+      @called
+      (vpop buf)
+      (macptr-ptr imm2 buf)
+      (stw imm0 0 imm2)
+      (stw imm1 4 imm2)
+      (stfs fp1 8 imm2)
+      (stfd fp1 16 imm2)
+      (restore-full-lisp-context)
+      (li arg_z (target-nil-value))
+      (bx lr))
+    )
+  #+ppc64-target
+  (progn
+  ;;; There are a few funky, non-obvious things going on here.
+  ;;; The main %FF-CALL function uses WITH-VARIABLE-C-FRAME;
+  ;;; the compiler will generate code to pop that frame off
+  ;;; of the C/control stack, but the subprim that implements
+  ;;; %ff-call has already popped it off.  To put things back
+  ;;; in balance, the LAP function %%FF-RESULT pushes an
+  ;;; extra frame on the cstack.
+  ;;; %FF-CALL calls %%FF-RESULT to box the result, which may
+  ;;; be in r3/imm0 or in fp1.  It's critical that the call
+  ;;; to %%FF-RESULT not be compiled as "multiple-value returning",
+  ;;; since the MV machinery may clobber IMM0.
+    (defarmlapfunction %%ff-result ((spec arg_z))
+      (stdu sp -160 sp)
+      (ld arg_y ':void nfn)
+      (cmpd cr0 spec arg_y)
+      (ld arg_x ':address nfn)
+      (cmpd cr1 spec arg_x)
+      (ld temp3 ':single-float nfn)
+      (cmpd cr2 spec temp3)
+      (ld arg_y ':double-float nfn)
+      (cmpd cr3 spec arg_y)
+      (ld arg_x ':unsigned-doubleword nfn)
+      (cmpd cr4 spec arg_x)
+      (ld temp3 ':signed-doubleword nfn)
+      (cmpd cr5 spec temp3)
+      (beq cr0 @void)
+      (beq cr1 @address)
+      (beq cr2 @single-float)
+      (beq cr3 @double-float)
+      (beq cr4 @unsigned-doubleword)
+      (beq cr5 @signed-doubleword)
+      (box-fixnum arg_z imm0)
+      (bx lr)
+      @void
+      (li arg_z nil)
+      (bx lr)
+      @address
+      (li imm1 ppc64::macptr-header)
+      (subi allocptr allocptr (- ppc64::macptr.size ppc64::fulltag-misc))
+      (tdlt allocptr allocbase)
+      (std imm1 ppc64::misc-header-offset allocptr)
+      (mov arg_z allocptr)
+      (clrrdi allocptr allocptr 4)
+      (std imm0 ppc64::macptr.address arg_z)
+      (bx lr)
+      @single-float
+      (put-single-float fp1 arg_z)
+      (bx lr)
+      @double-float
+      (li imm1 ppc64::double-float-header)
+      (subi allocptr allocptr (- ppc64::double-float.size ppc64::fulltag-misc))
+      (tdlt allocptr allocbase)
+      (std imm1 ppc64::misc-header-offset allocptr)
+      (mov arg_z allocptr)
+      (clrrdi allocptr allocptr 4)
+      (stfd fp1 ppc64::macptr.address arg_z)
+      (bx lr)
+      @unsigned-doubleword
+      (ba .SPmakeu64)
+      @signed-doubleword
+      (ba .SPmakes64))
+  ;;; This is just here so that we can jump to a subprim from lisp.
+    (defarmlapfunction %do-ff-call ((regbuf arg_y) (entry arg_z))
+      (cmpdi cr0 regbuf nil)
+      (bnea cr0 .SPpoweropen-ffcall-return-registers)
+      (ba .SPpoweropen-ffcall))
+    (defun %ff-call (entry &rest specs-and-vals)
+      (declare (dynamic-extent specs-and-vals))
+      (let* ((len (length specs-and-vals))
+             (total-words 0)
+             (registers nil))
+        (declare (fixnum len total-words))
+        (let* ((result-spec (or (car (last specs-and-vals)) :void))
+               (nargs (ash (the fixnum (1- len)) -1)))
+          (declare (fixnum nargs))
+          (ecase result-spec
+            ((:address :unsigned-doubleword :signed-doubleword
+                       :single-float :double-float
+                       :signed-fullword :unsigned-fullword
+                       :signed-halfword :unsigned-halfword
+                       :signed-byte :unsigned-byte
+                       :void)
+             (do* ((i 0 (1+ i))
+                   (specs specs-and-vals (cddr specs))
+                   (spec (car specs) (car specs)))
+                  ((= i nargs))
+               (declare (fixnum i))
+               (case spec
+                 (:registers nil)
+                 ((:address :unsigned-doubleword :signed-doubleword
+                            :single-float :double-float
+                            :signed-fullword :unsigned-fullword
+                            :signed-halfword :unsigned-halfword
+                            :signed-byte :unsigned-byte
+                            :hybrid-int-float :hybrid-float-float
+                            :hybrid-float-int)
+                  (incf total-words))
+                 (t (if (typep spec 'unsigned-byte)
+                      (incf total-words spec)
+                      (error "unknown arg spec ~s" spec)))))
+             (%stack-block ((fp-args (* 13 8)))
+               (with-variable-c-frame
+                   total-words frame
+                   (with-macptrs ((argptr))
+(defun %ff-call (entry &rest specs-and-vals)
+  (declare (dynamic-extent specs-and-vals))
+  (let* ((len (length specs-and-vals))
+         (total-words 0))
+    (declare (fixnum len total-words))
+    (let* ((result-spec (or (car (last specs-and-vals)) :void))
+           (nargs (ash (the fixnum (1- len)) -1)))
+      (declare (fixnum nargs))
+      (ecase result-spec
+        ((:address :unsigned-doubleword :signed-doubleword
+                   :single-float :double-float
+                   :signed-fullword :unsigned-fullword
+                   :signed-halfword :unsigned-halfword
+                   :signed-byte :unsigned-byte
+                   :void)
+         (do* ((i 0 (1+ i))
+               (specs specs-and-vals (cddr specs))
+               (spec (car specs) (car specs)))
+              ((= i nargs))
+           (declare (fixnum i))
+           (case spec
+             ((:address :single-float
+                        :signed-fullword :unsigned-fullword
+                        :signed-halfword :unsigned-halfword
+                        :signed-byte :unsigned-byte)
+              (incf total-words))
+             ((:double-float :unsigned-doubleword :signed-doubleword)
+              (setq total-words (+ total-words (logand total-words 1)))
+              (incf total-words 2))
+             (t (if (typep spec 'unsigned-byte)
+                  (incf total-words spec)
+                  (error "unknown arg spec ~s" spec)))))
+         ;; It's necessary to ensure that the C frame is the youngest thing on
+         ;; the foreign stack here.
+         (let* ((tag (cons nil nil)))
+           (declare (dynamic-extent tag))
+           (%stack-block ((result 8))
+             (catch tag
+               (with-macptrs ((argptr))
+                 (with-variable-c-frame
+                     total-words frame
                      (%setf-macptr-to-object argptr frame)
+                     (let* ((offset ppc64::c-frame.param0)
+                            (n-fp-args 0))
+                       (declare (fixnum offset n-fp-args))
+                     (let* ((arg-offset 8))
+                       (declare (fixnum arg-offset))
                        (do* ((i 0 (1+ i))
                              (specs specs-and-vals (cddr specs))
 …
                          (declare (fixnum i))
                          (case spec
+                           (:registers (setq registers val))
+                           (:address (setf (%get-ptr argptr offset) val)
+                                     (incf offset 8))
+                           ((:signed-doubleword :signed-fullword :signed-halfword
+                                                :signed-byte)
+                            (setf (%%get-signed-longlong argptr offset) val)
+                            (incf offset 8))
+                           ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword
+                                                  :unsigned-byte)
+                            (setf (%%get-unsigned-longlong argptr offset) val)
+                            (incf offset 8))
+                           (:hybrid-int-float
+                            (setf (%%get-unsigned-longlong argptr offset) val)
+                            (when (< n-fp-args 13)
+                              (setf (%get-double-float fp-args (* n-fp-args 8))
+                                    (%double-float (%get-single-float argptr (+ offset 4)))))
+                            (incf n-fp-args)
+                            (incf offset 8))
+                           (:hybrid-float-int
+                            (setf (%%get-unsigned-longlong argptr offset) val)
+                            (when (< n-fp-args 13)
+                              (setf (%get-double-float fp-args (* n-fp-args 8))
+                                    (%double-float (%get-single-float argptr offset))))
+                            (incf n-fp-args)
+                            (incf offset 8))
+                           (:hybrid-float-float
+                            (setf (%%get-unsigned-longlong argptr offset) val)
+                            (when (< n-fp-args 13)
+                              (setf (%get-double-float fp-args (* n-fp-args 8))
+                                    (%double-float (%get-single-float argptr offset))))
+                            (incf n-fp-args)
+                            (when (< n-fp-args 13)
+                              (setf (%get-double-float fp-args (* n-fp-args 8))
+                                    (%double-float (%get-single-float argptr (+ offset 4)))))
+                            (incf n-fp-args)
+                            (incf offset 8))
+                           (:address
+                            (setf (%get-ptr argptr arg-offset) val)
+                            (incf arg-offset 4))
+                           (:signed-doubleword
+                            (when (logtest 7 arg-offset)
+                              (incf arg-offset 4))
+                            (setf (%%get-signed-longlong argptr arg-offset) val)
+                            (incf arg-offset 8))
+                           ((:signed-fullword :signed-halfword :signed-byte)
+                            (setf (%get-signed-long argptr arg-offset) val)
+                            (incf arg-offset 4))
+                           (:unsigned-doubleword
+                             (when (logtest 7 arg-offset)
+                               (incf arg-offset 4))
+                             (setf (%%get-unsigned-longlong argptr arg-offset) val)
+                             (incf arg-offset 8))
+                           ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
+                            (setf (%get-unsigned-long argptr arg-offset) val)
+                            (incf arg-offset 4))
                            (:double-float
+                            (setf (%get-double-float argptr offset) val)
+                            (when (< n-fp-args 13)
+                              (setf (%get-double-float fp-args (* n-fp-args 8)) val))
+                            (incf n-fp-args)
+                            (incf offset 8))
+                            (when (logtest 7 arg-offset)
+                              (incf arg-offset 4))
+                            (setf (%get-double-float argptr arg-offset) val)
+                            (incf arg-offset 8))
                            (:single-float
+                            (setf (%get-single-float argptr offset) val)
+                            (when (< n-fp-args 13)
+                              (setf (%get-double-float fp-args (* n-fp-args 8))
+                                    (%double-float val)))
+                            (incf n-fp-args)
+                            (incf offset 8))
+                            (setf (%get-single-float argptr arg-offset) val)
+                            (incf arg-offset 4))
                            (t
+                            (let* ((p 0))
+                              (declare (fixnum p))
+                              (dotimes (i (the fixnum spec))
+                                (setf (%get-ptr argptr offset) (%get-ptr val p))
+                                (incf p 8)
+                                (incf offset 8))))))
+                       (%load-fp-arg-regs n-fp-args fp-args)
+                       (%do-ff-call registers entry)
+                       (values (%%ff-result result-spec)))))))))))
+    )
+  )
+)
+                              (let* ((p 0))
+                                (declare (fixnum p))
+                                (dotimes (i (the fixnum spec))
+                                  (setf (%get-ptr argptr arg-offset) (%get-ptr val p))
+                                  (incf p 4)
+                                  (incf arg-offset 4)))))))
+                         (%do-ff-call tag result entry))))
+             (ecase result-spec
+               (:void nil)
+               (:address (%get-ptr result 0))
+               (:unsigned-byte (%get-unsigned-byte result 0))
+               (:signed-byte (%get-signed-byte result 0))
+               (:unsigned-halfword (%get-unsigned-word result 0))
+               (:signed-halfword (%get-signed-word result 0))
+               (:unsigned-fullword (%get-unsigned-long result 0))
+               (:signed-fullword (%get-signed-long result 0))
+               (:unsigned-doubleword (%get-natural result 0))
+               (:signed-doubleword (%get-signed-natural result 0))
+               (:single-float (%get-single-float result 0))
+               (:double-float (%get-double-float result 0))))))))))

Note: See TracChangeset for help on using the changeset viewer.