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 ;;; If a single-float arg has to go on the stack, it's promoted to
  61 ;;; double.  That way, C programs can get subtle rounding errors when
  62 ;;; unrelated arguments are introduced.
  63
  64 #!-darwin
  65 (define-alien-type-method (single-float :arg-tn) (type state)
  66   (declare (ignore type))
  67   (let* ((fprs (arg-state-fpr-args state)))
  68     (cond ((< fprs 8)
  69            (incf (arg-state-fpr-args state))
  70            ;; Assign outgoing FPRs starting at FP1
  71            (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
  72           (t
  73            (let* ((stack-offset (arg-state-stack-frame-size state)))
  74              (if (oddp stack-offset)
  75                (incf stack-offset))
  76              (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
  77              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
  78
  79 #!+darwin
  80 (define-alien-type-method (single-float :arg-tn) (type state)
  81   (declare (ignore type))
  82   (let* ((fprs (arg-state-fpr-args state))
  83          (gprs (arg-state-gpr-args state)))
  84     (cond ((< gprs 8) ; and by implication also (< fprs 13)
  85            (incf (arg-state-fpr-args state))
  86            ;; Assign outgoing FPRs starting at FP1
  87            (list (my-make-wired-tn 'single-float 'single-reg (1+ fprs))
  88                  (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)))
  89           ((< fprs 13)
  90            ;; See comments below for double-float.
  91            (incf (arg-state-fpr-args state))
  92            (incf (arg-state-stack-frame-size state))
  93            (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
  94           (t
  95            ;; Pass on stack only
  96            (let ((stack-offset (arg-state-stack-frame-size state)))
  97              (incf (arg-state-stack-frame-size state))
  98              (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
  99 #!-darwin
 100 (define-alien-type-method (double-float :arg-tn) (type state)
 101   (declare (ignore type))
 102   (let* ((fprs (arg-state-fpr-args state)))
 103     (cond ((< fprs 8)
 104            (incf (arg-state-fpr-args state))
 105            ;; Assign outgoing FPRs starting at FP1
 106            (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
 107           (t
 108            (let* ((stack-offset (arg-state-stack-frame-size state)))
 109              (if (oddp stack-offset)
 110                (incf stack-offset))
 111              (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
 112              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
 113
 114 #!+darwin
 115 (define-alien-type-method (double-float :arg-tn) (type state)
 116   (declare (ignore type))
 117   (let ((fprs (arg-state-fpr-args state))
 118         (gprs (arg-state-gpr-args state)))
 119     (cond ((< gprs 8) ; and by implication also (< fprs 13)
 120            (incf (arg-state-fpr-args state))
 121            ;; Assign outgoing FPRs starting at FP1
 122            ;;
 123            ;; The PowerOpen ABI says float values are stored in float
 124            ;; regs.  But if we're calling a varargs function, we also
 125            ;; need to put the float into some gprs.  We indicate this
 126            ;; to %alien-funcall ir2-convert by making a list of the
 127            ;; TNs for the float reg and for the int regs.
 128            ;;
 129            (list (my-make-wired-tn 'double-float 'double-reg (1+ fprs))
 130                  (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
 131                  (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
 132           ((< fprs 13)
 133            (incf (arg-state-fpr-args state))
 134            (list (my-make-wired-tn 'double-float 'double-reg (1+ fprs))
 135                  (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
 136                  (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
 137           (t
 138            ;; Pass on stack only
 139            (let ((stack-offset (arg-state-stack-frame-size state)))
 140              (incf (arg-state-stack-frame-size state) 2)
 141              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
 142
 143 ;;; Result state handling
 144
 145 (defstruct result-state
 146   (num-results 0))
 147
 148 (defun result-reg-offset (slot)
 149   (ecase slot
 150     (0 nl0-offset)
 151     (1 nl1-offset)))
 152
 153 ;;; FIXME: These #!-DARWIN methods should be adjusted to take a state
 154 ;;; argument, firstly because that's our "official" API (see
 155 ;;; src/code/host-alieneval) and secondly because that way we can
 156 ;;; probably have less duplication of code.  -- CSR, 2003-07-29
 157
 158 #!-darwin
 159 (define-alien-type-method (system-area-pointer :result-tn) (type)
 160   (declare (ignore type))
 161   (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
 162
 163 #!+darwin
 164 (define-alien-type-method (system-area-pointer :result-tn) (type state)
 165   (declare (ignore type))
 166   (let ((num-results (result-state-num-results state)))
 167     (setf (result-state-num-results state) (1+ num-results))
 168     (my-make-wired-tn 'system-area-pointer 'sap-reg
 169                       (result-reg-offset num-results))))
 170
 171 #!-darwin
 172 (define-alien-type-method (single-float :result-tn) (type)
 173   (declare (ignore type state))
 174   (my-make-wired-tn 'single-float 'single-reg 1))
 175
 176 #!+darwin
 177 (define-alien-type-method (single-float :result-tn) (type state)
 178   (declare (ignore type state))
 179   (my-make-wired-tn 'single-float 'single-reg 1))
 180
 181 #!-darwin
 182 (define-alien-type-method (double-float :result-tn) (type)
 183   (declare (ignore type))
 184   (my-make-wired-tn 'double-float 'double-reg 1))
 185
 186 #!+darwin
 187 (define-alien-type-method (double-float :result-tn) (type state)
 188   (declare (ignore type state))
 189   (my-make-wired-tn 'double-float 'double-reg 1))
 190
 191 #!-darwin
 192 (define-alien-type-method (values :result-tn) (type)
 193   (mapcar #'(lambda (type)
 194               (invoke-alien-type-method :result-tn type))
 195           (alien-values-type-values type)))
 196
 197 #!+darwin
 198 (define-alien-type-method (values :result-tn) (type state)
 199   (let ((values (alien-values-type-values type)))
 200     (when (> (length values) 2)
 201       (error "Too many result values from c-call."))
 202     (mapcar #'(lambda (type)
 203                 (invoke-alien-type-method :result-tn type state))
 204             values)))
 205 #!-darwin
 206 (define-alien-type-method (integer :result-tn) (type)
 207   (if (alien-integer-type-signed type)
 208       (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
 209       (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
 210
 211 #!+darwin
 212 (define-alien-type-method (integer :result-tn) (type state)
 213   (let ((num-results (result-state-num-results state)))
 214     (setf (result-state-num-results state) (1+ num-results))
 215     (multiple-value-bind (ptype reg-sc)
 216         (if (alien-integer-type-signed type)
 217             (values 'signed-byte-32 'signed-reg)
 218             (values 'unsigned-byte-32 'unsigned-reg))
 219       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
 220
 221
 222 (!def-vm-support-routine make-call-out-tns (type)
 223   (declare (type alien-fun-type type))
 224   (let ((arg-state (make-arg-state)))
 225     (collect ((arg-tns))
 226       (dolist (arg-type (alien-fun-type-arg-types type))
 227         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 228       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
 229               (* (arg-state-stack-frame-size arg-state) n-word-bytes)
 230               (arg-tns)
 231               (invoke-alien-type-method
 232                :result-tn
 233                (alien-fun-type-result-type type)
 234                #!+darwin (make-result-state))))))
 235
 236 #!+darwin
 237 (deftransform %alien-funcall ((function type &rest args))
 238   (aver (sb!c::constant-lvar-p type))
 239   (let* ((type (sb!c::lvar-value type))
 240          (arg-types (alien-fun-type-arg-types type))
 241          (result-type (alien-fun-type-result-type type)))
 242     (aver (= (length arg-types) (length args)))
 243     ;; We need to do something special for 64-bit integer arguments
 244     ;; and results.
 245     (if (or (some #'(lambda (type)
 246                       (and (alien-integer-type-p type)
 247                            (> (sb!alien::alien-integer-type-bits type) 32)))
 248                   arg-types)
 249             (and (alien-integer-type-p result-type)
 250                  (> (sb!alien::alien-integer-type-bits result-type) 32)))
 251         (collect ((new-args) (lambda-vars) (new-arg-types))
 252                  (dolist (type arg-types)
 253                    (let ((arg (gensym)))
 254                      (lambda-vars arg)
 255                      (cond ((and (alien-integer-type-p type)
 256                                  (> (sb!alien::alien-integer-type-bits type) 32))
 257                             ;; 64-bit long long types are stored in
 258                             ;; consecutive locations, most significant word
 259                             ;; first (big-endian).
 260                             (new-args `(ash ,arg -32))
 261                             (new-args `(logand ,arg #xffffffff))
 262                             (if (alien-integer-type-signed type)
 263                                 (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
 264                                 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
 265                             (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
 266                            (t
 267                             (new-args arg)
 268                             (new-arg-types type)))))
 269                  (cond ((and (alien-integer-type-p result-type)
 270                              (> (sb!alien::alien-integer-type-bits result-type) 32))
 271                         (let ((new-result-type
 272                                (let ((sb!alien::*values-type-okay* t))
 273                                  (parse-alien-type
 274                                   (if (alien-integer-type-signed result-type)
 275                                       '(values (signed 32) (unsigned 32))
 276                                       '(values (unsigned 32) (unsigned 32)))
 277                                   (sb!kernel:make-null-lexenv)))))
 278                           `(lambda (function type ,@(lambda-vars))
 279                             (declare (ignore type))
 280                             (multiple-value-bind (high low)
 281                                 (%alien-funcall function
 282                                                 ',(make-alien-fun-type
 283                                                    :arg-types (new-arg-types)
 284                                                    :result-type new-result-type)
 285                                                 ,@(new-args))
 286                               (logior low (ash high 32))))))
 287                        (t
 288                         `(lambda (function type ,@(lambda-vars))
 289                           (declare (ignore type))
 290                           (%alien-funcall function
 291                            ',(make-alien-fun-type
 292                               :arg-types (new-arg-types)
 293                               :result-type result-type)
 294                            ,@(new-args))))))
 295         (sb!c::give-up-ir1-transform))))
 296
 297 (define-vop (foreign-symbol-sap)
 298   (:translate foreign-symbol-sap)
 299   (:policy :fast-safe)
 300   (:args)
 301   (:arg-types (:constant simple-string))
 302   (:info foreign-symbol)
 303   (:results (res :scs (sap-reg)))
 304   (:result-types system-area-pointer)
 305   (:generator 2
 306     (inst lr res  (make-fixup foreign-symbol :foreign))))
 307
 308 #!+linkage-table
 309 (define-vop (foreign-symbol-dataref-sap)
 310   (:translate foreign-symbol-dataref-sap)
 311   (:policy :fast-safe)
 312   (:args)
 313   (:arg-types (:constant simple-string))
 314   (:info foreign-symbol)
 315   (:results (res :scs (sap-reg)))
 316   (:result-types system-area-pointer)
 317   (:temporary (:scs (non-descriptor-reg)) addr)
 318   (:generator 2
 319     (inst lr addr (make-fixup foreign-symbol :foreign-dataref))
 320     (loadw res addr)))
 321
 322 (define-vop (call-out)
 323   (:args (function :scs (sap-reg) :target cfunc)
 324          (args :more t))
 325   (:results (results :more t))
 326   (:ignore args results)
 327   (:save-p t)
 328   (:temporary (:sc any-reg :offset cfunc-offset
 329                    :from (:argument 0) :to (:result 0)) cfunc)
 330   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 331   (:temporary (:scs (non-descriptor-reg)) temp)
 332   (:vop-var vop)
 333   (:generator 0
 334     (let ((cur-nfp (current-nfp-tn vop)))
 335       (when cur-nfp
 336         (store-stack-tn nfp-save cur-nfp))
 337       (inst lr temp (make-fixup "call_into_c" :foreign))
 338       (inst mtctr temp)
 339       (move cfunc function)
 340       (inst bctrl)
 341       (when cur-nfp
 342         (load-stack-tn cur-nfp nfp-save)))))
 343
 344
 345 (define-vop (alloc-number-stack-space)
 346   (:info amount)
 347   (:results (result :scs (sap-reg any-reg)))
 348   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 349   (:generator 0
 350     (unless (zerop amount)
 351       ;; FIXME: I don't understand why we seem to be adding
 352       ;; NUMBER-STACK-DISPLACEMENT twice here.  Weird.  -- CSR,
 353       ;; 2003-08-20
 354       (let ((delta (- (logandc2 (+ amount number-stack-displacement
 355                                    +stack-alignment-bytes+)
 356                                 +stack-alignment-bytes+))))
 357         (cond ((>= delta (ash -1 16))
 358                (inst stwu nsp-tn nsp-tn delta))
 359               (t
 360                (inst lr temp delta)
 361                (inst stwux  nsp-tn nsp-tn temp)))))
 362     (unless (location= result nsp-tn)
 363       ;; They are only location= when the result tn was allocated by
 364       ;; make-call-out-tns above, which takes the number-stack-displacement
 365       ;; into account itself.
 366       (inst addi result nsp-tn number-stack-displacement))))
 367
 368 (define-vop (dealloc-number-stack-space)
 369   (:info amount)
 370   (:policy :fast-safe)
 371   (:generator 0
 372     (unless (zerop amount)
 373       (let ((delta (logandc2 (+ amount number-stack-displacement
 374                                 +stack-alignment-bytes+)
 375                              +stack-alignment-bytes+)))
 376         (cond ((< delta (ash 1 16))
 377                (inst addi nsp-tn nsp-tn delta))
 378               (t
 379                (inst lwz nsp-tn nsp-tn 0)))))))
 380
 381 #-sb-xc-host
 382 (progn
 383   (defun alien-callback-accessor-form (type sap offset)
 384     (let ((parsed-type
 385            (sb!alien::parse-alien-type type (sb!kernel:make-null-lexenv))))
 386       (cond ((sb!alien::alien-integer-type-p parsed-type)
 387              ;; Unaligned access is slower, but possible, so this is nice and
 388              ;; simple. Also, we're a big-endian machine, so we need to get
 389              ;; byte offsets correct.
 390              (let ((bits (sb!alien::alien-type-bits parsed-type)))
 391                (let ((byte-offset
 392                       (cond ((< bits n-word-bits)
 393                              (- n-word-bytes
 394                                 (ceiling bits n-byte-bits)))
 395                             (t 0))))
 396                  `(deref (sap-alien (sap+ ,sap
 397                                           ,(+ byte-offset offset))
 398                                     (* ,type))))))
 399             (t
 400              `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))))))
 401
 402   ;;; The "Mach-O Runtime Conventions" document for OS X almost specifies
 403   ;;; the calling convention (it neglects to mention that the linkage
 404   ;;; area is 24 bytes).
 405   (defconstant n-foreign-linkage-area-bytes 24)
 406
 407   ;;; Returns a vector in static space containing machine code for the
 408   ;;; callback wrapper
 409   (defun alien-callback-assembler-wrapper (index result-type argument-types)
 410     (flet ((make-gpr (n)
 411              (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
 412            (make-fpr (n)
 413              (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
 414       (let* ((segment (make-segment)))
 415         (assemble (segment)
 416           ;; To save our arguments, we follow the algorithm sketched in the
 417           ;; "PowerPC Calling Conventions" section of that document.
 418           ;;
 419           ;; CLH: There are a couple problems here. First, we bail if
 420           ;; we run out of registers. AIUI, we can just ignore the extra
 421           ;; args here and we will be ok...
 422           (let ((words-processed 0)
 423                 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
 424                 (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))
 425                 (stack-pointer (make-gpr 1)))
 426             (labels ((save-arg (type words)
 427                        (let ((integerp (not (alien-float-type-p type)))
 428                              (offset (+ (* words-processed n-word-bytes)
 429                                         n-foreign-linkage-area-bytes)))
 430                          (cond (integerp
 431                                 (dotimes (k words)
 432                                   (let ((gpr (pop gprs)))
 433                                     (when gpr
 434                                       (inst stw gpr stack-pointer offset))
 435                                     (incf words-processed)
 436                                     (incf offset n-word-bytes))))
 437                                ;; The handling of floats is a little ugly
 438                                ;; because we hard-code the number of words
 439                                ;; for single- and double-floats.
 440                                ((alien-single-float-type-p type)
 441                                 (pop gprs)
 442                                 (let ((fpr (pop fprs)))
 443                                   (when fpr
 444                                     (inst stfs fpr stack-pointer offset)))
 445                                 (incf words-processed))
 446                                ((alien-double-float-type-p type)
 447                                 (setf gprs (cddr gprs))
 448                                 (let ((fpr (pop fprs)))
 449                                   (when fpr
 450                                     (inst stfd fpr stack-pointer offset)))
 451                                 (incf words-processed 2))
 452                                (t
 453                                 (bug "Unknown alien floating point type: ~S" type))))))
 454               (mapc #'save-arg
 455                     argument-types
 456                     (mapcar (lambda (arg)
 457                               (ceiling (alien-type-bits arg) n-word-bits))
 458                             argument-types))))
 459           ;; Set aside room for the return area just below sp, then
 460           ;; actually call funcall3: funcall3 (call-alien-function,
 461           ;; index, args, return-area)
 462           ;;
 463           ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
 464           ;; because they're word-aligned. Kinda gross, but hey ...
 465           (let* ((n-return-area-words
 466                   (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
 467                  (n-return-area-bytes (* n-return-area-words n-word-bytes))
 468                  ;; FIXME: magic constant, and probably n-args-bytes
 469                  (args-size (* 3 n-word-bytes))
 470                  ;; FIXME: n-frame-bytes?
 471                  (frame-size (logandc2 (+ n-foreign-linkage-area-bytes
 472                                           n-return-area-bytes
 473                                           args-size
 474                                           +stack-alignment-bytes+)
 475                                        +stack-alignment-bytes+)))
 476             (destructuring-bind (sp r0 arg1 arg2 arg3 arg4)
 477                 (mapcar #'make-gpr '(1 0 3 4 5 6))
 478               ;; FIXME: This is essentially the same code as LR in
 479               ;; insts.lisp, but attempting to use (INST LR ...) instead
 480               ;; of this function results in callbacks not working.  Why?
 481               ;;   --njf, 2006-01-04
 482               (flet ((load-address-into (reg addr)
 483                        (let ((high (ldb (byte 16 16) addr))
 484                              (low (ldb (byte 16 0) addr)))
 485                          (inst lis reg high)
 486                          (inst ori reg reg low))))
 487                 ;; Setup the args
 488
 489                 ;; CLH 2006/02/10 -Following JES' logic in
 490                 ;; x86-64/c-call.lisp, we need to access
 491                 ;; ENTER-ALIEN-CALLBACK through the symbol-value slot
 492                 ;; of SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that
 493                 ;; it works if GC moves ENTER-ALIEN-CALLBACK.
 494                 ;;
 495                 ;; old way:
 496                 ;; (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback))
 497
 498                 ;; new way:
 499                 ;; (load-symbol arg1 'sb!alien::*enter-alien-callback*)
 500                 ;;
 501                 ;; whoops: can't use load-symbol here as null-tn might
 502                 ;; not be loaded with the proper value as we are
 503                 ;; coming in from C code. Use nil-value constant
 504                 ;; instead, following the logic in x86-64/c-call.lisp.
 505                 (load-address-into arg1 (+ nil-value (static-symbol-offset
 506                                                       'sb!alien::*enter-alien-callback*)))
 507                 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
 508
 509                 (inst li arg2 (fixnumize index))
 510                 (inst addi arg3 sp n-foreign-linkage-area-bytes)
 511                 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
 512                 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
 513                 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
 514                 ;; --NS 2005-06-11
 515                 (inst addi arg4 sp (- n-return-area-bytes))
 516                 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
 517                 ;; Save sp, setup the frame
 518                 (inst mflr r0)
 519                 (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant
 520                 (inst stwu sp sp (- frame-size))
 521                 ;; Make the call
 522                 (load-address-into r0 (foreign-symbol-address "funcall3"))
 523                 (inst mtlr r0)
 524                 (inst blrl))
 525               ;; We're back!  Restore sp and lr, load the return value from just
 526               ;; under sp, and return.
 527               (inst lwz sp sp 0)
 528               (inst lwz r0 sp (* 2 n-word-bytes))
 529               (inst mtlr r0)
 530               (cond
 531                 ((sb!alien::alien-single-float-type-p result-type)
 532                  (let ((f1 (make-fpr 1)))
 533                    (inst lfs f1 sp (- (* n-return-area-words n-word-bytes)))))
 534                 ((sb!alien::alien-double-float-type-p result-type)
 535                  (let ((f1 (make-fpr 1)))
 536                    (inst lfd f1 sp (- (* n-return-area-words n-word-bytes)))))
 537                 ((sb!alien::alien-void-type-p result-type)
 538                  ;; Nothing to do
 539                  )
 540                 (t
 541                  (loop with gprs = (mapcar #'make-gpr '(3 4))
 542                     repeat n-return-area-words
 543                     for gpr = (pop gprs)
 544                     for offset from (- (* n-return-area-words n-word-bytes))
 545                     by n-word-bytes
 546                     do
 547                       (unless gpr
 548                         (bug "Out of return registers in alien-callback trampoline."))
 549                       (inst lwz gpr sp offset))))
 550               (inst blr))))
 551         (finalize-segment segment)
 552         ;; Now that the segment is done, convert it to a static
 553         ;; vector we can point foreign code to.
 554         (let* ((buffer (sb!assem::segment-buffer segment))
 555                (vector (make-static-vector (length buffer)
 556                                            :element-type '(unsigned-byte 8)
 557                                            :initial-contents buffer))
 558                (sap (sb!sys:vector-sap vector)))
 559           (sb!alien:alien-funcall
 560            (sb!alien:extern-alien "ppc_flush_icache"
 561                                   (function void
 562                                             system-area-pointer
 563                                             unsigned-long))
 564            sap (length buffer))
 565           vector)))))