1.0.15.36: fix bug 423
[sbcl.git] / 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   (:result-types system-area-pointer)
432   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
433   (:generator 0
434     (unless (zerop amount)
435       ;; FIXME: I don't understand why we seem to be adding
436       ;; NUMBER-STACK-DISPLACEMENT twice here.  Weird.  -- CSR,
437       ;; 2003-08-20
438       (let ((delta (- (logandc2 (+ amount number-stack-displacement
439                                    +stack-alignment-bytes+)
440                                 +stack-alignment-bytes+))))
441         (cond ((>= delta (ash -1 16))
442                (inst stwu nsp-tn nsp-tn delta))
443               (t
444                (inst lr temp delta)
445                (inst stwux  nsp-tn nsp-tn temp)))))
446     (unless (location= result nsp-tn)
447       ;; They are only location= when the result tn was allocated by
448       ;; make-call-out-tns above, which takes the number-stack-displacement
449       ;; into account itself.
450       (inst addi result nsp-tn number-stack-displacement))))
451
452 (define-vop (dealloc-number-stack-space)
453   (:info amount)
454   (:policy :fast-safe)
455   (:generator 0
456     (unless (zerop amount)
457       (let ((delta (logandc2 (+ amount number-stack-displacement
458                                 +stack-alignment-bytes+)
459                              +stack-alignment-bytes+)))
460         (cond ((< delta (ash 1 16))
461                (inst addi nsp-tn nsp-tn delta))
462               (t
463                (inst lwz nsp-tn nsp-tn 0)))))))
464
465 #-sb-xc-host
466 (progn
467   (defun alien-callback-accessor-form (type sap offset)
468     (let ((parsed-type
469            (sb!alien::parse-alien-type type (sb!kernel:make-null-lexenv))))
470       (cond ((sb!alien::alien-integer-type-p parsed-type)
471              ;; Unaligned access is slower, but possible, so this is nice and
472              ;; simple. Also, we're a big-endian machine, so we need to get
473              ;; byte offsets correct.
474              (let ((bits (sb!alien::alien-type-bits parsed-type)))
475                (let ((byte-offset
476                       (cond ((< bits n-word-bits)
477                              (- n-word-bytes
478                                 (ceiling bits n-byte-bits)))
479                             (t 0))))
480                  `(deref (sap-alien (sap+ ,sap
481                                           ,(+ byte-offset offset))
482                                     (* ,type))))))
483             (t
484              `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))))))
485
486   ;;; The "Mach-O Runtime Conventions" document for OS X almost
487   ;;; specifies the calling convention (it neglects to mention that
488   ;;; the linkage area is 24 bytes).
489   #!+darwin
490   (defconstant n-foreign-linkage-area-bytes 24)
491
492   ;;; On linux only use 8 bytes for LR and Back chain.  JRXR
493   ;;; 2006/11/10.
494   #!-darwin
495   (defconstant n-foreign-linkage-area-bytes 8)
496
497   ;;; Returns a vector in static space containing machine code for the
498   ;;; callback wrapper.  Linux version.  JRXR.  2006/11/13
499   #!-darwin
500   (defun alien-callback-assembler-wrapper (index result-type argument-types)
501     (flet ((make-gpr (n)
502              (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
503            (make-fpr (n)
504              (make-random-tn :kind :normal :sc (sc-or-lose
505                                                 'double-reg) :offset
506                                                 n)))
507       (let* ((segment (make-segment)))
508         (assemble (segment)
509           ;; Copy args from registers or stack to new position
510           ;; on stack.
511           (let* (
512                  ;; Argument store.
513                  (arg-store-size
514                   (* n-word-bytes
515                      (apply '+
516                          (mapcar (lambda (type)
517                                    (ceiling (alien-type-bits type)
518                                             n-word-bits))
519                                  argument-types ))))
520                  ;; Return area allocation.
521                  (n-return-area-words
522                   (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
523                  (n-return-area-bytes (* n-return-area-words
524                                          n-word-bytes))
525                  ;; FIXME: magic constant, and probably n-args-bytes
526                  ;; JRXR: What's this for?  Copied from Darwin.
527                  (args-size (* 3 n-word-bytes))
528                  (frame-size (logandc2
529                               (+ arg-store-size
530                                  n-return-area-bytes
531                                  args-size
532                                  SB!VM::NUMBER-STACK-DISPLACEMENT
533                                  +stack-alignment-bytes+)
534                               +stack-alignment-bytes+))
535                  (return-area-pos (- frame-size
536                                      SB!VM::NUMBER-STACK-DISPLACEMENT
537                                      args-size))
538                  (arg-store-pos (- return-area-pos
539                                    n-return-area-bytes))
540                  (stack-pointer (make-gpr 1))
541                  (r0 (make-gpr 0))
542                  (f0 (make-fpr 0))
543                  (in-words-processed 0)
544                  (out-words-processed 0)
545                  (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
546                  (fprs (mapcar #'make-fpr
547                                '(1 2 3 4 5 6 7 8))) )
548             ;; Setup useful functions and then copy all args.
549             (flet ((load-address-into (reg addr)
550                        (let ((high (ldb (byte 16 16) addr))
551                              (low (ldb (byte 16 0) addr)))
552                          (inst lis reg high)
553                          (inst ori reg reg low)))
554                    (save-arg (type words)
555                      (let ((integerp (not (alien-float-type-p type)))
556                            (in-offset (+ (* in-words-processed n-word-bytes)
557                                          n-foreign-linkage-area-bytes))
558                            (out-offset (- (* out-words-processed n-word-bytes)
559                                           arg-store-pos)))
560                        (cond (integerp
561                               (if (and
562                                    ;; Only upto long longs are passed
563                                    ;; in registers.
564                                    (<= words 2)
565                                    ;; And needs space for whole arg,
566                                    ;; including alignment.
567                                    (<= (+ words
568                                           (rem (length gprs) words))
569                                        (length gprs)))
570                                   (progn
571                                     (if (/= 0
572                                             (rem (length gprs) words))
573                                         (pop gprs))
574                                     (dotimes (k words)
575                                       (let ((gpr (pop gprs)))
576                                         (inst stw gpr stack-pointer
577                                               out-offset))
578                                       (incf out-words-processed)
579                                       (incf out-offset n-word-bytes)))
580                                   (progn
581                                     ;; First ensure alignment.
582                                     ;; FIXME!  If passing structures
583                                     ;; becomes allowable, then this is
584                                     ;; broken.
585                                     (if (/= 0
586                                             (rem in-words-processed
587                                                  words))
588                                         (progn
589                                           (incf in-words-processed)
590                                           (incf in-offset
591                                                 n-word-bytes)))
592                                     (dotimes (k words)
593                                       ;; Copy from memory to memory.
594                                       (inst lwz r0 stack-pointer
595                                             in-offset)
596                                       (inst stw r0 stack-pointer
597                                             out-offset)
598                                       (incf out-words-processed)
599                                       (incf out-offset n-word-bytes)
600                                       (incf in-words-processed)
601                                       (incf in-offset n-word-bytes)))))
602                              ;; The handling of floats is a little ugly
603                              ;; because we hard-code the number of words
604                              ;; for single- and double-floats.
605                              ((alien-single-float-type-p type)
606                               (let ((fpr (pop fprs)))
607                                 (if fpr
608                                     (inst stfs fpr stack-pointer out-offset)
609                                     (progn
610                                       ;; The ABI says that floats
611                                       ;; stored on the stack are
612                                       ;; promoted to doubles.  gcc
613                                       ;; stores them as floats.
614                                       ;; Follow gcc here.
615                                       ;;  => no alignment needed either.
616                                       (inst lfs f0
617                                             stack-pointer in-offset)
618                                       (inst stfs f0
619                                             stack-pointer out-offset)
620                                       (incf in-words-processed))))
621                               (incf out-words-processed))
622                              ((alien-double-float-type-p type)
623                               (let ((fpr (pop fprs)))
624                                 (if fpr
625                                     (inst stfd fpr stack-pointer out-offset)
626                                     (progn
627                                       ;; Ensure alignment.
628                                       (if (oddp in-words-processed)
629                                           (progn
630                                             (incf in-words-processed)
631                                             (incf in-offset n-word-bytes)))
632                                       (inst lfd f0
633                                             stack-pointer in-offset)
634                                       (inst stfd f0
635                                             stack-pointer out-offset)
636                                       (incf in-words-processed 2))))
637                               (incf out-words-processed 2))
638                              (t
639                               (bug "Unknown alien floating point type: ~S" type))))))
640               (mapc #'save-arg
641                     argument-types
642                     (mapcar (lambda (arg)
643                               (ceiling (alien-type-bits arg) n-word-bits))
644                             argument-types))
645
646               ;; Arranged the args, allocated the return area.  Now
647               ;; actuall call funcall3:  funcall3 (call-alien-function,
648               ;; index, args, return-area)
649
650               (destructuring-bind (arg1 arg2 arg3 arg4)
651                   (mapcar #'make-gpr '(3 4 5 6))
652                 (load-address-into arg1 (+ nil-value (static-symbol-offset
653                                                       'sb!alien::*enter-alien-callback*)))
654                 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
655                 (inst li arg2 (fixnumize index))
656                 (inst addi arg3 stack-pointer (- arg-store-pos))
657                 (inst addi arg4 stack-pointer (- return-area-pos)))
658
659               ;; Setup everything.  Now save sp, setup the frame.
660               (inst mflr r0)
661               (inst stw r0 stack-pointer (* 2 n-word-bytes)) ; FIXME: magic
662                                         ; constant, copied from Darwin.
663               (inst stwu stack-pointer stack-pointer (- frame-size))
664
665               ;; And make the call.
666               (load-address-into r0 (foreign-symbol-address "funcall3"))
667               (inst mtlr r0)
668               (inst blrl)
669
670               ;; We're back!  Restore sp and lr, load the
671               ;; return value from just under sp, and return.
672               (inst lwz stack-pointer stack-pointer 0)
673               (inst lwz r0 stack-pointer (* 2 n-word-bytes))
674               (inst mtlr r0)
675               (cond
676                 ((sb!alien::alien-single-float-type-p result-type)
677                  (let ((f1 (make-fpr 1)))
678                    (inst lfs f1 stack-pointer (- return-area-pos))))
679                 ((sb!alien::alien-double-float-type-p result-type)
680                  (let ((f1 (make-fpr 1)))
681                    (inst lfd f1 stack-pointer (- return-area-pos))))
682                 ((sb!alien::alien-void-type-p result-type)
683                  ;; Nothing to do
684                  )
685                 (t
686                  (loop with gprs = (mapcar #'make-gpr '(3 4))
687                        repeat n-return-area-words
688                        for gpr = (pop gprs)
689                        for offset from (- return-area-pos)
690                        by n-word-bytes
691                        do
692                        (unless gpr
693                          (bug "Out of return registers in alien-callback trampoline."))
694                        (inst lwz gpr stack-pointer offset))))
695               (inst blr))))
696         (finalize-segment segment)
697
698         ;; Now that the segment is done, convert it to a static
699         ;; vector we can point foreign code to.
700         (let* ((buffer (sb!assem::segment-buffer segment))
701                (vector (make-static-vector (length buffer)
702                                            :element-type '(unsigned-byte 8)
703                                            :initial-contents buffer))
704                (sap (sb!sys:vector-sap vector)))
705           (sb!alien:alien-funcall
706            (sb!alien:extern-alien "ppc_flush_icache"
707                                   (function void
708                                             system-area-pointer
709                                             unsigned-long))
710            sap (length buffer))
711           vector))))
712
713   ;;; Returns a vector in static space containing machine code for the
714   ;;; callback wrapper
715   #!+darwin
716   (defun alien-callback-assembler-wrapper (index result-type argument-types)
717     (flet ((make-gpr (n)
718              (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
719            (make-fpr (n)
720              (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
721       (let* ((segment (make-segment)))
722         (assemble (segment)
723           ;; To save our arguments, we follow the algorithm sketched in the
724           ;; "PowerPC Calling Conventions" section of that document.
725           ;;
726           ;; CLH: There are a couple problems here. First, we bail if
727           ;; we run out of registers. AIUI, we can just ignore the extra
728           ;; args here and we will be ok...
729           (let ((words-processed 0)
730                 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
731                 (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))
732                 (stack-pointer (make-gpr 1)))
733             (labels ((save-arg (type words)
734                        (let ((integerp (not (alien-float-type-p type)))
735                              (offset (+ (* words-processed n-word-bytes)
736                                         n-foreign-linkage-area-bytes)))
737                          (cond (integerp
738                                 (dotimes (k words)
739                                   (let ((gpr (pop gprs)))
740                                     (when gpr
741                                       (inst stw gpr stack-pointer offset))
742                                     (incf words-processed)
743                                     (incf offset n-word-bytes))))
744                                ;; The handling of floats is a little ugly
745                                ;; because we hard-code the number of words
746                                ;; for single- and double-floats.
747                                ((alien-single-float-type-p type)
748                                 (pop gprs)
749                                 (let ((fpr (pop fprs)))
750                                   (when fpr
751                                     (inst stfs fpr stack-pointer offset)))
752                                 (incf words-processed))
753                                ((alien-double-float-type-p type)
754                                 (setf gprs (cddr gprs))
755                                 (let ((fpr (pop fprs)))
756                                   (when fpr
757                                     (inst stfd fpr stack-pointer offset)))
758                                 (incf words-processed 2))
759                                (t
760                                 (bug "Unknown alien floating point type: ~S" type))))))
761               (mapc #'save-arg
762                     argument-types
763                     (mapcar (lambda (arg)
764                               (ceiling (alien-type-bits arg) n-word-bits))
765                             argument-types))))
766           ;; Set aside room for the return area just below sp, then
767           ;; actually call funcall3: funcall3 (call-alien-function,
768           ;; index, args, return-area)
769           ;;
770           ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
771           ;; because they're word-aligned. Kinda gross, but hey ...
772           (let* ((n-return-area-words
773                   (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
774                  (n-return-area-bytes (* n-return-area-words n-word-bytes))
775                  ;; FIXME: magic constant, and probably n-args-bytes
776                  (args-size (* 3 n-word-bytes))
777                  ;; FIXME: n-frame-bytes?
778                  (frame-size (logandc2 (+ n-foreign-linkage-area-bytes
779                                           n-return-area-bytes
780                                           args-size
781                                           +stack-alignment-bytes+)
782                                        +stack-alignment-bytes+)))
783             (destructuring-bind (sp r0 arg1 arg2 arg3 arg4)
784                 (mapcar #'make-gpr '(1 0 3 4 5 6))
785               ;; FIXME: This is essentially the same code as LR in
786               ;; insts.lisp, but attempting to use (INST LR ...) instead
787               ;; of this function results in callbacks not working.  Why?
788               ;;   --njf, 2006-01-04
789               (flet ((load-address-into (reg addr)
790                        (let ((high (ldb (byte 16 16) addr))
791                              (low (ldb (byte 16 0) addr)))
792                          (inst lis reg high)
793                          (inst ori reg reg low))))
794                 ;; Setup the args
795
796                 ;; CLH 2006/02/10 -Following JES' logic in
797                 ;; x86-64/c-call.lisp, we need to access
798                 ;; ENTER-ALIEN-CALLBACK through the symbol-value slot
799                 ;; of SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that
800                 ;; it works if GC moves ENTER-ALIEN-CALLBACK.
801                 ;;
802                 ;; old way:
803                 ;; (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback))
804
805                 ;; new way:
806                 ;; (load-symbol arg1 'sb!alien::*enter-alien-callback*)
807                 ;;
808                 ;; whoops: can't use load-symbol here as null-tn might
809                 ;; not be loaded with the proper value as we are
810                 ;; coming in from C code. Use nil-value constant
811                 ;; instead, following the logic in x86-64/c-call.lisp.
812                 (load-address-into arg1 (+ nil-value (static-symbol-offset
813                                                       'sb!alien::*enter-alien-callback*)))
814                 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
815
816                 (inst li arg2 (fixnumize index))
817                 (inst addi arg3 sp n-foreign-linkage-area-bytes)
818                 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
819                 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
820                 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
821                 ;; --NS 2005-06-11
822                 (inst addi arg4 sp (- n-return-area-bytes))
823                 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
824                 ;; Save sp, setup the frame
825                 (inst mflr r0)
826                 (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant
827                 (inst stwu sp sp (- frame-size))
828                 ;; Make the call
829                 (load-address-into r0 (foreign-symbol-address "funcall3"))
830                 (inst mtlr r0)
831                 (inst blrl))
832               ;; We're back!  Restore sp and lr, load the return value from just
833               ;; under sp, and return.
834               (inst lwz sp sp 0)
835               (inst lwz r0 sp (* 2 n-word-bytes))
836               (inst mtlr r0)
837               (cond
838                 ((sb!alien::alien-single-float-type-p result-type)
839                  (let ((f1 (make-fpr 1)))
840                    (inst lfs f1 sp (- (* n-return-area-words n-word-bytes)))))
841                 ((sb!alien::alien-double-float-type-p result-type)
842                  (let ((f1 (make-fpr 1)))
843                    (inst lfd f1 sp (- (* n-return-area-words n-word-bytes)))))
844                 ((sb!alien::alien-void-type-p result-type)
845                  ;; Nothing to do
846                  )
847                 (t
848                  (loop with gprs = (mapcar #'make-gpr '(3 4))
849                     repeat n-return-area-words
850                     for gpr = (pop gprs)
851                     for offset from (- (* n-return-area-words n-word-bytes))
852                     by n-word-bytes
853                     do
854                       (unless gpr
855                         (bug "Out of return registers in alien-callback trampoline."))
856                       (inst lwz gpr sp offset))))
857               (inst blr))))
858         (finalize-segment segment)
859         ;; Now that the segment is done, convert it to a static
860         ;; vector we can point foreign code to.
861         (let* ((buffer (sb!assem::segment-buffer segment))
862                (vector (make-static-vector (length buffer)
863                                            :element-type '(unsigned-byte 8)
864                                            :initial-contents buffer))
865                (sap (sb!sys:vector-sap vector)))
866           (sb!alien:alien-funcall
867            (sb!alien:extern-alien "ppc_flush_icache"
868                                   (function void
869                                             system-area-pointer
870                                             unsigned-long))
871            sap (length buffer))
872           vector)))))