src/compiler/ppc/c-call.lisp

   1 ;;;; VOPs and other machine-specific support routines for call-out to C
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 ;;; Return the number of bytes needed for the current non-descriptor
  15 ;;; stack frame.  Non-descriptor stack frames must be multiples of 16
  16 ;;; bytes under the PPC SVr4 ABI (though the EABI may be less
  17 ;;; restrictive).  On linux, two words are reserved for the stack
  18 ;;; backlink and saved LR (see SB!VM::NUMBER-STACK-DISPLACEMENT).
  19
  20 (defconstant +stack-alignment-bytes+
  21   ;; Duh.  PPC Linux (and VxWorks) adhere to the EABI.
  22   #!-darwin 7
  23   ;; But Darwin doesn't
  24   #!+darwin 15)
  25
  26 (defun my-make-wired-tn (prim-type-name sc-name offset)
  27   (make-wired-tn (primitive-type-or-lose prim-type-name)
  28                  (sc-number-or-lose sc-name)
  29                  offset))
  30
  31 (defstruct arg-state
  32   (gpr-args 0)
  33   (fpr-args 0)
  34   ;; SVR4 [a]abi wants two words on stack (callee saved lr,
  35   ;; backpointer).
  36   #!-darwin (stack-frame-size 2)
  37   ;; PowerOpen ABI wants 8 words on the stack corresponding to GPR3-10
  38   ;; in addition to the 6 words of link area (see number-stack-displacement)
  39   #!+darwin (stack-frame-size (+ 8 6)))
  40
  41 (defun int-arg (state prim-type reg-sc stack-sc)
  42   (let ((reg-args (arg-state-gpr-args state)))
  43     (cond ((< reg-args 8)
  44            (setf (arg-state-gpr-args state) (1+ reg-args))
  45            (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
  46           (t
  47            (let ((frame-size (arg-state-stack-frame-size state)))
  48              (setf (arg-state-stack-frame-size state) (1+ frame-size))
  49              (my-make-wired-tn prim-type stack-sc frame-size))))))
  50
  51 (define-alien-type-method (integer :arg-tn) (type state)
  52   (if (alien-integer-type-signed type)
  53       (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
  54       (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
  55
  56 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  57   (declare (ignore type))
  58   (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
  59
  60 ;;; The Linux/PPC 32bit ABI says:
  61 ;;;
  62 ;;;   If a single-float arg has to go on the stack, it's promoted to
  63 ;;;   a double.
  64 ;;;
  65 ;;; gcc does:
  66 ;;;
  67 ;;;   Excess floats stored on the stack are stored as floats.
  68 ;;;
  69 ;;; We follow gcc.
  70 #!-darwin
  71 (define-alien-type-method (single-float :arg-tn) (type state)
  72   (declare (ignore type))
  73   (let* ((fprs (arg-state-fpr-args state)))
  74     (cond ((< fprs 8)
  75            (incf (arg-state-fpr-args state))
  76            ;; Assign outgoing FPRs starting at FP1
  77            (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
  78           (t
  79            (let* ((stack-offset (arg-state-stack-frame-size state)))
  80              (setf (arg-state-stack-frame-size state) (+ stack-offset 1))
  81              (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
  82
  83 ;;; If a single-float arg has to go on the stack, it's promoted to
  84 ;;; double.  That way, C programs can get subtle rounding errors when
  85 ;;; unrelated arguments are introduced.
  86 #!+darwin
  87 (define-alien-type-method (single-float :arg-tn) (type state)
  88   (declare (ignore type))
  89   (let* ((fprs (arg-state-fpr-args state))
  90          (gprs (arg-state-gpr-args state)))
  91     (cond ((< gprs 8) ; and by implication also (< fprs 13)
  92            (incf (arg-state-fpr-args state))
  93            ;; Assign outgoing FPRs starting at FP1
  94            (list (my-make-wired-tn 'single-float 'single-reg (1+ fprs))
  95                  (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)))
  96           ((< fprs 13)
  97            ;; See comments below for double-float.
  98            (incf (arg-state-fpr-args state))
  99            (incf (arg-state-stack-frame-size state))
 100            (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
 101           (t
 102            ;; Pass on stack only
 103            (let ((stack-offset (arg-state-stack-frame-size state)))
 104              (incf (arg-state-stack-frame-size state))
 105              (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
 106
 107 #!-darwin
 108 (define-alien-type-method (double-float :arg-tn) (type state)
 109   (declare (ignore type))
 110   (let* ((fprs (arg-state-fpr-args state)))
 111     (cond ((< fprs 8)
 112            (incf (arg-state-fpr-args state))
 113            ;; Assign outgoing FPRs starting at FP1
 114            (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
 115           (t
 116            (let* ((stack-offset (arg-state-stack-frame-size state)))
 117              (if (oddp stack-offset)
 118                (incf stack-offset))
 119              (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
 120              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
 121
 122 #!+darwin
 123 (define-alien-type-method (double-float :arg-tn) (type state)
 124   (declare (ignore type))
 125   (let ((fprs (arg-state-fpr-args state))
 126         (gprs (arg-state-gpr-args state)))
 127     (cond ((< gprs 8) ; and by implication also (< fprs 13)
 128            (incf (arg-state-fpr-args state))
 129            ;; Assign outgoing FPRs starting at FP1
 130            ;;
 131            ;; The PowerOpen ABI says float values are stored in float
 132            ;; regs.  But if we're calling a varargs function, we also
 133            ;; need to put the float into some gprs.  We indicate this
 134            ;; to %alien-funcall ir2-convert by making a list of the
 135            ;; TNs for the float reg and for the int regs.
 136            ;;
 137            (list (my-make-wired-tn 'double-float 'double-reg (1+ fprs))
 138                  (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
 139                  (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
 140           ((< fprs 13)
 141            (incf (arg-state-fpr-args state))
 142            (list (my-make-wired-tn 'double-float 'double-reg (1+ fprs))
 143                  (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
 144                  (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
 145           (t
 146            ;; Pass on stack only
 147            (let ((stack-offset (arg-state-stack-frame-size state)))
 148              (incf (arg-state-stack-frame-size state) 2)
 149              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
 150
 151 ;;; Result state handling
 152
 153 (defstruct result-state
 154   (num-results 0))
 155
 156 (defun result-reg-offset (slot)
 157   (ecase slot
 158     (0 nl0-offset)
 159     (1 nl1-offset)))
 160
 161 ;;; FIXME: These #!-DARWIN methods should be adjusted to take a state
 162 ;;; argument, firstly because that's our "official" API (see
 163 ;;; src/code/host-alieneval) and secondly because that way we can
 164 ;;; probably have less duplication of code.  -- CSR, 2003-07-29
 165
 166 (define-alien-type-method (system-area-pointer :result-tn) (type state)
 167   (declare (ignore type))
 168   (let ((num-results (result-state-num-results state)))
 169     (setf (result-state-num-results state) (1+ num-results))
 170     (my-make-wired-tn 'system-area-pointer 'sap-reg
 171                       (result-reg-offset num-results))))
 172
 173 (define-alien-type-method (single-float :result-tn) (type state)
 174   (declare (ignore type state))
 175   (my-make-wired-tn 'single-float 'single-reg 1))
 176
 177 (define-alien-type-method (double-float :result-tn) (type state)
 178   (declare (ignore type state))
 179   (my-make-wired-tn 'double-float 'double-reg 1))
 180
 181 (define-alien-type-method (values :result-tn) (type state)
 182   (let ((values (alien-values-type-values type)))
 183     (when (> (length values) 2)
 184       (error "Too many result values from c-call."))
 185     (mapcar #'(lambda (type)
 186                 (invoke-alien-type-method :result-tn type state))
 187             values)))
 188
 189 (define-alien-type-method (integer :result-tn) (type state)
 190   (let ((num-results (result-state-num-results state)))
 191     (setf (result-state-num-results state) (1+ num-results))
 192     (multiple-value-bind (ptype reg-sc)
 193         (if (alien-integer-type-signed type)
 194             (values 'signed-byte-32 'signed-reg)
 195             (values 'unsigned-byte-32 'unsigned-reg))
 196       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
 197
 198 (!def-vm-support-routine make-call-out-tns (type)
 199   (declare (type alien-fun-type type))
 200   (let ((arg-state (make-arg-state)))
 201     (collect ((arg-tns))
 202       (dolist (arg-type (alien-fun-type-arg-types type))
 203         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 204       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
 205               (* (arg-state-stack-frame-size arg-state) n-word-bytes)
 206               (arg-tns)
 207               (invoke-alien-type-method
 208                :result-tn
 209                (alien-fun-type-result-type type)
 210                (make-result-state))))))
 211
 212
 213 ;;; Sort out long longs, by splitting them up.  However, need to take
 214 ;;; care about register/stack alignment and whether they will fully
 215 ;;; fit into registers or must go on the stack.
 216 #!-darwin
 217 (deftransform %alien-funcall ((function type &rest args))
 218   (aver (sb!c::constant-lvar-p type))
 219   (let* ((type (sb!c::lvar-value type))
 220          (arg-types (alien-fun-type-arg-types type))
 221          (result-type (alien-fun-type-result-type type))
 222          (gprs 0)
 223          (fprs 0)
 224          (stack 0))
 225     (aver (= (length arg-types) (length args)))
 226     ;; We need to do something special for 64-bit integer arguments
 227     ;; and results.
 228     (if (or (some #'(lambda (type)
 229                       (and (alien-integer-type-p type)
 230                            (> (sb!alien::alien-integer-type-bits type) 32)))
 231                   arg-types)
 232             (and (alien-integer-type-p result-type)
 233                  (> (sb!alien::alien-integer-type-bits result-type) 32)))
 234         (collect ((new-args) (lambda-vars) (new-arg-types))
 235           (dolist (type arg-types)
 236             (let ((arg (gensym)))
 237               (lambda-vars arg)
 238               (cond ((and (alien-integer-type-p type)
 239                           (> (sb!alien::alien-integer-type-bits type) 32))
 240                      (when (or
 241                             (oddp gprs)
 242                             (and
 243                              (oddp stack)
 244                              (> gprs 7)))
 245                        ;; Need to pad for alignment.
 246                        (if (oddp gprs)
 247                            (incf gprs)
 248                            (incf stack))
 249                        (new-args 0)
 250                        (new-arg-types (parse-alien-type
 251                                        '(unsigned 32)
 252                                        (sb!kernel:make-null-lexenv))))
 253                      (if (< gprs 8)
 254                          (incf gprs 2)
 255                          (incf stack 2))
 256                      (new-args `(ash ,arg -32))
 257                      (new-args `(logand ,arg #xffffffff))
 258                      (if (alien-integer-type-signed type)
 259                          (new-arg-types (parse-alien-type
 260                                          '(signed 32)
 261                                          (sb!kernel:make-null-lexenv)))
 262                          (new-arg-types (parse-alien-type
 263                                          '(unsigned 32)
 264                                          (sb!kernel:make-null-lexenv))))
 265                      (new-arg-types (parse-alien-type
 266                                      '(unsigned 32)
 267                                      (sb!kernel:make-null-lexenv))))
 268                     ((alien-integer-type-p type)
 269                      (if (< gprs 8)
 270                          (incf gprs 1)
 271                          (incf stack 1))
 272                      (new-args arg)
 273                      (new-arg-types type))
 274                     ((alien-single-float-type-p type)
 275                      (if (< fprs 8)
 276                          (incf fprs)
 277                          (incf stack))
 278                      (new-args arg)
 279                      (new-arg-types type))
 280                     ((alien-double-float-type-p type)
 281                      (if (< fprs 8)
 282                          (incf fprs)
 283                          (if (oddp stack)
 284                              (incf stack 3)   ; Doubles are aligned on
 285                              (incf stack 2))) ; the stack.
 286                      (new-args arg)
 287                      (new-arg-types type))
 288                     (t
 289                      (new-args arg)
 290                      (new-arg-types type)))))
 291                  (cond ((and (alien-integer-type-p result-type)
 292                              (> (sb!alien::alien-integer-type-bits result-type) 32))
 293                         (let ((new-result-type
 294                                (let ((sb!alien::*values-type-okay* t))
 295                                  (parse-alien-type
 296                                   (if (alien-integer-type-signed result-type)
 297                                       '(values (signed 32) (unsigned 32))
 298                                       '(values (unsigned 32) (unsigned 32)))
 299                                   (sb!kernel:make-null-lexenv)))))
 300                           `(lambda (function type ,@(lambda-vars))
 301                             (declare (ignore type))
 302                             (multiple-value-bind (high low)
 303                                 (%alien-funcall function
 304                                                 ',(make-alien-fun-type
 305                                                    :arg-types (new-arg-types)
 306                                                    :result-type new-result-type)
 307                                                 ,@(new-args))
 308                               (logior low (ash high 32))))))
 309                        (t
 310                         `(lambda (function type ,@(lambda-vars))
 311                           (declare (ignore type))
 312                           (%alien-funcall function
 313                            ',(make-alien-fun-type
 314                               :arg-types (new-arg-types)
 315                               :result-type result-type)
 316                            ,@(new-args))))))
 317         (sb!c::give-up-ir1-transform))))
 318
 319 #!+darwin
 320 (deftransform %alien-funcall ((function type &rest args))
 321   (aver (sb!c::constant-lvar-p type))
 322   (let* ((type (sb!c::lvar-value type))
 323          (arg-types (alien-fun-type-arg-types type))
 324          (result-type (alien-fun-type-result-type type)))
 325     (aver (= (length arg-types) (length args)))
 326     ;; We need to do something special for 64-bit integer arguments
 327     ;; and results.
 328     (if (or (some #'(lambda (type)
 329                       (and (alien-integer-type-p type)
 330                            (> (sb!alien::alien-integer-type-bits type) 32)))
 331                   arg-types)
 332             (and (alien-integer-type-p result-type)
 333                  (> (sb!alien::alien-integer-type-bits result-type) 32)))
 334         (collect ((new-args) (lambda-vars) (new-arg-types))
 335                  (dolist (type arg-types)
 336                    (let ((arg (gensym)))
 337                      (lambda-vars arg)
 338                      (cond ((and (alien-integer-type-p type)
 339                                  (> (sb!alien::alien-integer-type-bits type) 32))
 340                             ;; 64-bit long long types are stored in
 341                             ;; consecutive locations, most significant word
 342                             ;; first (big-endian).
 343                             (new-args `(ash ,arg -32))
 344                             (new-args `(logand ,arg #xffffffff))
 345                             (if (alien-integer-type-signed type)
 346                                 (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
 347                                 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
 348                             (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
 349                            (t
 350                             (new-args arg)
 351                             (new-arg-types type)))))
 352                  (cond ((and (alien-integer-type-p result-type)
 353                              (> (sb!alien::alien-integer-type-bits result-type) 32))
 354                         (let ((new-result-type
 355                                (let ((sb!alien::*values-type-okay* t))
 356                                  (parse-alien-type
 357                                   (if (alien-integer-type-signed result-type)
 358                                       '(values (signed 32) (unsigned 32))
 359                                       '(values (unsigned 32) (unsigned 32)))
 360                                   (sb!kernel:make-null-lexenv)))))
 361                           `(lambda (function type ,@(lambda-vars))
 362                             (declare (ignore type))
 363                             (multiple-value-bind (high low)
 364                                 (%alien-funcall function
 365                                                 ',(make-alien-fun-type
 366                                                    :arg-types (new-arg-types)
 367                                                    :result-type new-result-type)
 368                                                 ,@(new-args))
 369                               (logior low (ash high 32))))))
 370                        (t
 371                         `(lambda (function type ,@(lambda-vars))
 372                           (declare (ignore type))
 373                           (%alien-funcall function
 374                            ',(make-alien-fun-type
 375                               :arg-types (new-arg-types)
 376                               :result-type result-type)
 377                            ,@(new-args))))))
 378         (sb!c::give-up-ir1-transform))))
 379
 380 (define-vop (foreign-symbol-sap)
 381   (:translate foreign-symbol-sap)
 382   (:policy :fast-safe)
 383   (:args)
 384   (:arg-types (:constant simple-string))
 385   (:info foreign-symbol)
 386   (:results (res :scs (sap-reg)))
 387   (:result-types system-area-pointer)
 388   (:generator 2
 389     (inst lr res  (make-fixup foreign-symbol :foreign))))
 390
 391 #!+linkage-table
 392 (define-vop (foreign-symbol-dataref-sap)
 393   (:translate foreign-symbol-dataref-sap)
 394   (:policy :fast-safe)
 395   (:args)
 396   (:arg-types (:constant simple-string))
 397   (:info foreign-symbol)
 398   (:results (res :scs (sap-reg)))
 399   (:result-types system-area-pointer)
 400   (:temporary (:scs (non-descriptor-reg)) addr)
 401   (:generator 2
 402     (inst lr addr (make-fixup foreign-symbol :foreign-dataref))
 403     (loadw res addr)))
 404
 405 (define-vop (call-out)
 406   (:args (function :scs (sap-reg) :target cfunc)
 407          (args :more t))
 408   (:results (results :more t))
 409   (:ignore args results)
 410   (:save-p t)
 411   (:temporary (:sc any-reg :offset cfunc-offset
 412                    :from (:argument 0) :to (:result 0)) cfunc)
 413   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 414   (:temporary (:scs (non-descriptor-reg)) temp)
 415   (:vop-var vop)
 416   (:generator 0
 417     (let ((cur-nfp (current-nfp-tn vop)))
 418       (when cur-nfp
 419         (store-stack-tn nfp-save cur-nfp))
 420       (inst lr temp (make-fixup "call_into_c" :foreign))
 421       (inst mtctr temp)
 422       (move cfunc function)
 423       (inst bctrl)
 424       (when cur-nfp
 425         (load-stack-tn cur-nfp nfp-save)))))
 426
 427
 428 (define-vop (alloc-number-stack-space)
 429   (:info amount)
 430   (:results (result :scs (sap-reg any-reg)))
 431   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 432   (:generator 0
 433     (unless (zerop amount)
 434       ;; FIXME: I don't understand why we seem to be adding
 435       ;; NUMBER-STACK-DISPLACEMENT twice here.  Weird.  -- CSR,
 436       ;; 2003-08-20
 437       (let ((delta (- (logandc2 (+ amount number-stack-displacement
 438                                    +stack-alignment-bytes+)
 439                                 +stack-alignment-bytes+))))
 440         (cond ((>= delta (ash -1 16))
 441                (inst stwu nsp-tn nsp-tn delta))
 442               (t
 443                (inst lr temp delta)
 444                (inst stwux  nsp-tn nsp-tn temp)))))
 445     (unless (location= result nsp-tn)
 446       ;; They are only location= when the result tn was allocated by
 447       ;; make-call-out-tns above, which takes the number-stack-displacement
 448       ;; into account itself.
 449       (inst addi result nsp-tn number-stack-displacement))))
 450
 451 (define-vop (dealloc-number-stack-space)
 452   (:info amount)
 453   (:policy :fast-safe)
 454   (:generator 0
 455     (unless (zerop amount)
 456       (let ((delta (logandc2 (+ amount number-stack-displacement
 457                                 +stack-alignment-bytes+)
 458                              +stack-alignment-bytes+)))
 459         (cond ((< delta (ash 1 16))
 460                (inst addi nsp-tn nsp-tn delta))
 461               (t
 462                (inst lwz nsp-tn nsp-tn 0)))))))
 463
 464 #-sb-xc-host
 465 (progn
 466   (defun alien-callback-accessor-form (type sap offset)
 467     (let ((parsed-type
 468            (sb!alien::parse-alien-type type (sb!kernel:make-null-lexenv))))
 469       (cond ((sb!alien::alien-integer-type-p parsed-type)
 470              ;; Unaligned access is slower, but possible, so this is nice and
 471              ;; simple. Also, we're a big-endian machine, so we need to get
 472              ;; byte offsets correct.
 473              (let ((bits (sb!alien::alien-type-bits parsed-type)))
 474                (let ((byte-offset
 475                       (cond ((< bits n-word-bits)
 476                              (- n-word-bytes
 477                                 (ceiling bits n-byte-bits)))
 478                             (t 0))))
 479                  `(deref (sap-alien (sap+ ,sap
 480                                           ,(+ byte-offset offset))
 481                                     (* ,type))))))
 482             (t
 483              `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))))))
 484
 485   ;;; The "Mach-O Runtime Conventions" document for OS X almost
 486   ;;; specifies the calling convention (it neglects to mention that
 487   ;;; the linkage area is 24 bytes).
 488   #!+darwin
 489   (defconstant n-foreign-linkage-area-bytes 24)
 490
 491   ;;; On linux only use 8 bytes for LR and Back chain.  JRXR
 492   ;;; 2006/11/10.
 493   #!-darwin
 494   (defconstant n-foreign-linkage-area-bytes 8)
 495
 496   ;;; Returns a vector in static space containing machine code for the
 497   ;;; callback wrapper.  Linux version.  JRXR.  2006/11/13
 498   #!-darwin
 499   (defun alien-callback-assembler-wrapper (index result-type argument-types)
 500     (flet ((make-gpr (n)
 501              (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
 502            (make-fpr (n)
 503              (make-random-tn :kind :normal :sc (sc-or-lose
 504                                                 'double-reg) :offset
 505                                                 n)))
 506       (let* ((segment (make-segment)))
 507         (assemble (segment)
 508           ;; Copy args from registers or stack to new position
 509           ;; on stack.
 510           (let* (
 511                  ;; Argument store.
 512                  (arg-store-size
 513                   (* n-word-bytes
 514                      (apply '+
 515                          (mapcar (lambda (type)
 516                                    (ceiling (alien-type-bits type)
 517                                             n-word-bits))
 518                                  argument-types ))))
 519                  ;; Return area allocation.
 520                  (n-return-area-words
 521                   (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
 522                  (n-return-area-bytes (* n-return-area-words
 523                                          n-word-bytes))
 524                  ;; FIXME: magic constant, and probably n-args-bytes
 525                  ;; JRXR: What's this for?  Copied from Darwin.
 526                  (args-size (* 3 n-word-bytes))
 527                  (frame-size (logandc2
 528                               (+ arg-store-size
 529                                  n-return-area-bytes
 530                                  args-size
 531                                  SB!VM::NUMBER-STACK-DISPLACEMENT
 532                                  +stack-alignment-bytes+)
 533                               +stack-alignment-bytes+))
 534                  (return-area-pos (- frame-size
 535                                      SB!VM::NUMBER-STACK-DISPLACEMENT
 536                                      args-size))
 537                  (arg-store-pos (- return-area-pos
 538                                    n-return-area-bytes))
 539                  (stack-pointer (make-gpr 1))
 540                  (r0 (make-gpr 0))
 541                  (f0 (make-fpr 0))
 542                  (in-words-processed 0)
 543                  (out-words-processed 0)
 544                  (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
 545                  (fprs (mapcar #'make-fpr
 546                                '(1 2 3 4 5 6 7 8))) )
 547             ;; Setup useful functions and then copy all args.
 548             (flet ((load-address-into (reg addr)
 549                        (let ((high (ldb (byte 16 16) addr))
 550                              (low (ldb (byte 16 0) addr)))
 551                          (inst lis reg high)
 552                          (inst ori reg reg low)))
 553                    (save-arg (type words)
 554                      (let ((integerp (not (alien-float-type-p type)))
 555                            (in-offset (+ (* in-words-processed n-word-bytes)
 556                                          n-foreign-linkage-area-bytes))
 557                            (out-offset (- (* out-words-processed n-word-bytes)
 558                                           arg-store-pos)))
 559                        (cond (integerp
 560                               (if (and
 561                                    ;; Only upto long longs are passed
 562                                    ;; in registers.
 563                                    (<= words 2)
 564                                    ;; And needs space for whole arg,
 565                                    ;; including alignment.
 566                                    (<= (+ words
 567                                           (rem (length gprs) words))
 568                                        (length gprs)))
 569                                   (progn
 570                                     (if (/= 0
 571                                             (rem (length gprs) words))
 572                                         (pop gprs))
 573                                     (dotimes (k words)
 574                                       (let ((gpr (pop gprs)))
 575                                         (inst stw gpr stack-pointer
 576                                               out-offset))
 577                                       (incf out-words-processed)
 578                                       (incf out-offset n-word-bytes)))
 579                                   (progn
 580                                     ;; First ensure alignment.
 581                                     ;; FIXME!  If passing structures
 582                                     ;; becomes allowable, then this is
 583                                     ;; broken.
 584                                     (if (/= 0
 585                                             (rem in-words-processed
 586                                                  words))
 587                                         (progn
 588                                           (incf in-words-processed)
 589                                           (incf in-offset
 590                                                 n-word-bytes)))
 591                                     (dotimes (k words)
 592                                       ;; Copy from memory to memory.
 593                                       (inst lwz r0 stack-pointer
 594                                             in-offset)
 595                                       (inst stw r0 stack-pointer
 596                                             out-offset)
 597                                       (incf out-words-processed)
 598                                       (incf out-offset n-word-bytes)
 599                                       (incf in-words-processed)
 600                                       (incf in-offset n-word-bytes)))))
 601                              ;; The handling of floats is a little ugly
 602                              ;; because we hard-code the number of words
 603                              ;; for single- and double-floats.
 604                              ((alien-single-float-type-p type)
 605                               (let ((fpr (pop fprs)))
 606                                 (if fpr
 607                                     (inst stfs fpr stack-pointer out-offset)
 608                                     (progn
 609                                       ;; The ABI says that floats
 610                                       ;; stored on the stack are
 611                                       ;; promoted to doubles.  gcc
 612                                       ;; stores them as floats.
 613                                       ;; Follow gcc here.
 614                                       ;;  => no alignment needed either.
 615                                       (inst lfs f0
 616                                             stack-pointer in-offset)
 617                                       (inst stfs f0
 618                                             stack-pointer out-offset)
 619                                       (incf in-words-processed))))
 620                               (incf out-words-processed))
 621                              ((alien-double-float-type-p type)
 622                               (let ((fpr (pop fprs)))
 623                                 (if fpr
 624                                     (inst stfd fpr stack-pointer out-offset)
 625                                     (progn
 626                                       ;; Ensure alignment.
 627                                       (if (oddp in-words-processed)
 628                                           (progn
 629                                             (incf in-words-processed)
 630                                             (incf in-offset n-word-bytes)))
 631                                       (inst lfd f0
 632                                             stack-pointer in-offset)
 633                                       (inst stfd f0
 634                                             stack-pointer out-offset)
 635                                       (incf in-words-processed 2))))
 636                               (incf out-words-processed 2))
 637                              (t
 638                               (bug "Unknown alien floating point type: ~S" type))))))
 639               (mapc #'save-arg
 640                     argument-types
 641                     (mapcar (lambda (arg)
 642                               (ceiling (alien-type-bits arg) n-word-bits))
 643                             argument-types))
 644
 645               ;; Arranged the args, allocated the return area.  Now
 646               ;; actuall call funcall3:  funcall3 (call-alien-function,
 647               ;; index, args, return-area)
 648
 649               (destructuring-bind (arg1 arg2 arg3 arg4)
 650                   (mapcar #'make-gpr '(3 4 5 6))
 651                 (load-address-into arg1 (+ nil-value (static-symbol-offset
 652                                                       'sb!alien::*enter-alien-callback*)))
 653                 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
 654                 (inst li arg2 (fixnumize index))
 655                 (inst addi arg3 stack-pointer (- arg-store-pos))
 656                 (inst addi arg4 stack-pointer (- return-area-pos)))
 657
 658               ;; Setup everything.  Now save sp, setup the frame.
 659               (inst mflr r0)
 660               (inst stw r0 stack-pointer (* 2 n-word-bytes)) ; FIXME: magic
 661                                         ; constant, copied from Darwin.
 662               (inst stwu stack-pointer stack-pointer (- frame-size))
 663
 664               ;; And make the call.
 665               (load-address-into r0 (foreign-symbol-address "funcall3"))
 666               (inst mtlr r0)
 667               (inst blrl)
 668
 669               ;; We're back!  Restore sp and lr, load the
 670               ;; return value from just under sp, and return.
 671               (inst lwz stack-pointer stack-pointer 0)
 672               (inst lwz r0 stack-pointer (* 2 n-word-bytes))
 673               (inst mtlr r0)
 674               (cond
 675                 ((sb!alien::alien-single-float-type-p result-type)
 676                  (let ((f1 (make-fpr 1)))
 677                    (inst lfs f1 stack-pointer (- return-area-pos))))
 678                 ((sb!alien::alien-double-float-type-p result-type)
 679                  (let ((f1 (make-fpr 1)))
 680                    (inst lfd f1 stack-pointer (- return-area-pos))))
 681                 ((sb!alien::alien-void-type-p result-type)
 682                  ;; Nothing to do
 683                  )
 684                 (t
 685                  (loop with gprs = (mapcar #'make-gpr '(3 4))
 686                        repeat n-return-area-words
 687                        for gpr = (pop gprs)
 688                        for offset from (- return-area-pos)
 689                        by n-word-bytes
 690                        do
 691                        (unless gpr
 692                          (bug "Out of return registers in alien-callback trampoline."))
 693                        (inst lwz gpr stack-pointer offset))))
 694               (inst blr))))
 695         (finalize-segment segment)
 696
 697         ;; Now that the segment is done, convert it to a static
 698         ;; vector we can point foreign code to.
 699         (let* ((buffer (sb!assem::segment-buffer segment))
 700                (vector (make-static-vector (length buffer)
 701                                            :element-type '(unsigned-byte 8)
 702                                            :initial-contents buffer))
 703                (sap (sb!sys:vector-sap vector)))
 704           (sb!alien:alien-funcall
 705            (sb!alien:extern-alien "ppc_flush_icache"
 706                                   (function void
 707                                             system-area-pointer
 708                                             unsigned-long))
 709            sap (length buffer))
 710           vector))))
 711
 712   ;;; Returns a vector in static space containing machine code for the
 713   ;;; callback wrapper
 714   #!+darwin
 715   (defun alien-callback-assembler-wrapper (index result-type argument-types)
 716     (flet ((make-gpr (n)
 717              (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
 718            (make-fpr (n)
 719              (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
 720       (let* ((segment (make-segment)))
 721         (assemble (segment)
 722           ;; To save our arguments, we follow the algorithm sketched in the
 723           ;; "PowerPC Calling Conventions" section of that document.
 724           ;;
 725           ;; CLH: There are a couple problems here. First, we bail if
 726           ;; we run out of registers. AIUI, we can just ignore the extra
 727           ;; args here and we will be ok...
 728           (let ((words-processed 0)
 729                 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
 730                 (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))
 731                 (stack-pointer (make-gpr 1)))
 732             (labels ((save-arg (type words)
 733                        (let ((integerp (not (alien-float-type-p type)))
 734                              (offset (+ (* words-processed n-word-bytes)
 735                                         n-foreign-linkage-area-bytes)))
 736                          (cond (integerp
 737                                 (dotimes (k words)
 738                                   (let ((gpr (pop gprs)))
 739                                     (when gpr
 740                                       (inst stw gpr stack-pointer offset))
 741                                     (incf words-processed)
 742                                     (incf offset n-word-bytes))))
 743                                ;; The handling of floats is a little ugly
 744                                ;; because we hard-code the number of words
 745                                ;; for single- and double-floats.
 746                                ((alien-single-float-type-p type)
 747                                 (pop gprs)
 748                                 (let ((fpr (pop fprs)))
 749                                   (when fpr
 750                                     (inst stfs fpr stack-pointer offset)))
 751                                 (incf words-processed))
 752                                ((alien-double-float-type-p type)
 753                                 (setf gprs (cddr gprs))
 754                                 (let ((fpr (pop fprs)))
 755                                   (when fpr
 756                                     (inst stfd fpr stack-pointer offset)))
 757                                 (incf words-processed 2))
 758                                (t
 759                                 (bug "Unknown alien floating point type: ~S" type))))))
 760               (mapc #'save-arg
 761                     argument-types
 762                     (mapcar (lambda (arg)
 763                               (ceiling (alien-type-bits arg) n-word-bits))
 764                             argument-types))))
 765           ;; Set aside room for the return area just below sp, then
 766           ;; actually call funcall3: funcall3 (call-alien-function,
 767           ;; index, args, return-area)
 768           ;;
 769           ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
 770           ;; because they're word-aligned. Kinda gross, but hey ...
 771           (let* ((n-return-area-words
 772                   (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
 773                  (n-return-area-bytes (* n-return-area-words n-word-bytes))
 774                  ;; FIXME: magic constant, and probably n-args-bytes
 775                  (args-size (* 3 n-word-bytes))
 776                  ;; FIXME: n-frame-bytes?
 777                  (frame-size (logandc2 (+ n-foreign-linkage-area-bytes
 778                                           n-return-area-bytes
 779                                           args-size
 780                                           +stack-alignment-bytes+)
 781                                        +stack-alignment-bytes+)))
 782             (destructuring-bind (sp r0 arg1 arg2 arg3 arg4)
 783                 (mapcar #'make-gpr '(1 0 3 4 5 6))
 784               ;; FIXME: This is essentially the same code as LR in
 785               ;; insts.lisp, but attempting to use (INST LR ...) instead
 786               ;; of this function results in callbacks not working.  Why?
 787               ;;   --njf, 2006-01-04
 788               (flet ((load-address-into (reg addr)
 789                        (let ((high (ldb (byte 16 16) addr))
 790                              (low (ldb (byte 16 0) addr)))
 791                          (inst lis reg high)
 792                          (inst ori reg reg low))))
 793                 ;; Setup the args
 794
 795                 ;; CLH 2006/02/10 -Following JES' logic in
 796                 ;; x86-64/c-call.lisp, we need to access
 797                 ;; ENTER-ALIEN-CALLBACK through the symbol-value slot
 798                 ;; of SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that
 799                 ;; it works if GC moves ENTER-ALIEN-CALLBACK.
 800                 ;;
 801                 ;; old way:
 802                 ;; (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback))
 803
 804                 ;; new way:
 805                 ;; (load-symbol arg1 'sb!alien::*enter-alien-callback*)
 806                 ;;
 807                 ;; whoops: can't use load-symbol here as null-tn might
 808                 ;; not be loaded with the proper value as we are
 809                 ;; coming in from C code. Use nil-value constant
 810                 ;; instead, following the logic in x86-64/c-call.lisp.
 811                 (load-address-into arg1 (+ nil-value (static-symbol-offset
 812                                                       'sb!alien::*enter-alien-callback*)))
 813                 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
 814
 815                 (inst li arg2 (fixnumize index))
 816                 (inst addi arg3 sp n-foreign-linkage-area-bytes)
 817                 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
 818                 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
 819                 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
 820                 ;; --NS 2005-06-11
 821                 (inst addi arg4 sp (- n-return-area-bytes))
 822                 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
 823                 ;; Save sp, setup the frame
 824                 (inst mflr r0)
 825                 (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant
 826                 (inst stwu sp sp (- frame-size))
 827                 ;; Make the call
 828                 (load-address-into r0 (foreign-symbol-address "funcall3"))
 829                 (inst mtlr r0)
 830                 (inst blrl))
 831               ;; We're back!  Restore sp and lr, load the return value from just
 832               ;; under sp, and return.
 833               (inst lwz sp sp 0)
 834               (inst lwz r0 sp (* 2 n-word-bytes))
 835               (inst mtlr r0)
 836               (cond
 837                 ((sb!alien::alien-single-float-type-p result-type)
 838                  (let ((f1 (make-fpr 1)))
 839                    (inst lfs f1 sp (- (* n-return-area-words n-word-bytes)))))
 840                 ((sb!alien::alien-double-float-type-p result-type)
 841                  (let ((f1 (make-fpr 1)))
 842                    (inst lfd f1 sp (- (* n-return-area-words n-word-bytes)))))
 843                 ((sb!alien::alien-void-type-p result-type)
 844                  ;; Nothing to do
 845                  )
 846                 (t
 847                  (loop with gprs = (mapcar #'make-gpr '(3 4))
 848                     repeat n-return-area-words
 849                     for gpr = (pop gprs)
 850                     for offset from (- (* n-return-area-words n-word-bytes))
 851                     by n-word-bytes
 852                     do
 853                       (unless gpr
 854                         (bug "Out of return registers in alien-callback trampoline."))
 855                       (inst lwz gpr sp offset))))
 856               (inst blr))))
 857         (finalize-segment segment)
 858         ;; Now that the segment is done, convert it to a static
 859         ;; vector we can point foreign code to.
 860         (let* ((buffer (sb!assem::segment-buffer segment))
 861                (vector (make-static-vector (length buffer)
 862                                            :element-type '(unsigned-byte 8)
 863                                            :initial-contents buffer))
 864                (sap (sb!sys:vector-sap vector)))
 865           (sb!alien:alien-funcall
 866            (sb!alien:extern-alien "ppc_flush_icache"
 867                                   (function void
 868                                             system-area-pointer
 869                                             unsigned-long))
 870            sap (length buffer))
 871           vector)))))