Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[b36697]: src / compiler / ppc / c-call.lisp Maximize Restore History

Download this file

c-call.lisp    386 lines (350 with data), 14.4 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
;;;; VOPs and other machine-specific support routines for call-out to C
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;; Return the number of bytes needed for the current non-descriptor
;;; stack frame. Non-descriptor stack frames must be multiples of 16
;;; bytes under the PPC SVr4 ABI (though the EABI may be less
;;; restrictive). On linux, two words are reserved for the stack
;;; backlink and saved LR (see SB!VM::NUMBER-STACK-DISPLACEMENT).
(defconstant +stack-alignment-bytes+
;; Duh. PPC Linux (and VxWorks) adhere to the EABI.
#!-darwin 7
;; But Darwin doesn't
#!+darwin 15)
(defun my-make-wired-tn (prim-type-name sc-name offset)
(make-wired-tn (primitive-type-or-lose prim-type-name)
(sc-number-or-lose sc-name)
offset))
(defstruct arg-state
(gpr-args 0)
(fpr-args 0)
;; SVR4 [a]abi wants two words on stack (callee saved lr,
;; backpointer).
#!-darwin (stack-frame-size 2)
;; PowerOpen ABI wants 8 words on the stack corresponding to GPR3-10
;; in addition to the 6 words of link area (see number-stack-displacement)
#!+darwin (stack-frame-size (+ 8 6)))
(defun int-arg (state prim-type reg-sc stack-sc)
(let ((reg-args (arg-state-gpr-args state)))
(cond ((< reg-args 8)
(setf (arg-state-gpr-args state) (1+ reg-args))
(my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
(t
(let ((frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ frame-size))
(my-make-wired-tn prim-type stack-sc frame-size))))))
(define-alien-type-method (integer :arg-tn) (type state)
(if (alien-integer-type-signed type)
(int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
(int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
(define-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
(int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
;;; If a single-float arg has to go on the stack, it's promoted to
;;; double. That way, C programs can get subtle rounding errors when
;;; unrelated arguments are introduced.
#!-darwin
(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state)))
(cond ((< fprs 8)
(incf (arg-state-fpr-args state))
;; Assign outgoing FPRs starting at FP1
(my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
(t
(let* ((stack-offset (arg-state-stack-frame-size state)))
(if (oddp stack-offset)
(incf stack-offset))
(setf (arg-state-stack-frame-size state) (+ stack-offset 2))
(my-make-wired-tn 'double-float 'double-stack stack-offset))))))
#!+darwin
(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state))
(gprs (arg-state-gpr-args state)))
(cond ((< gprs 8) ; and by implication also (< fprs 13)
;; Corresponding GPR is kept empty for functions with fixed args
(incf (arg-state-gpr-args state))
(incf (arg-state-fpr-args state))
;; Assign outgoing FPRs starting at FP1
(my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
((< fprs 13)
;; According to PowerOpen ABI, we need to pass those both in the
;; FPRs _and_ the stack. However empiric testing on OS X/gcc
;; shows they are only passed in FPRs, AFAICT.
;;
;; "I" in "AFAICT" probably refers to PRM. -- CSR, still
;; reverse-engineering comments in 2003 :-)
(incf (arg-state-fpr-args state))
(incf (arg-state-stack-frame-size state))
(my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
(t
;; Pass on stack only
(let ((stack-offset (arg-state-stack-frame-size state)))
(incf (arg-state-stack-frame-size state))
(my-make-wired-tn 'single-float 'single-stack stack-offset))))))
#!-darwin
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state)))
(cond ((< fprs 8)
(incf (arg-state-fpr-args state))
;; Assign outgoing FPRs starting at FP1
(my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
(t
(let* ((stack-offset (arg-state-stack-frame-size state)))
(if (oddp stack-offset)
(incf stack-offset))
(setf (arg-state-stack-frame-size state) (+ stack-offset 2))
(my-make-wired-tn 'double-float 'double-stack stack-offset))))))
#!+darwin
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((fprs (arg-state-fpr-args state))
(gprs (arg-state-gpr-args state)))
(cond ((< gprs 8) ; and by implication also (< fprs 13)
;; Corresponding GPRs are also kept empty
(incf (arg-state-gpr-args state) 2)
(when (> (arg-state-gpr-args state) 8)
;; Spill one word to stack
(decf (arg-state-gpr-args state))
(incf (arg-state-stack-frame-size state)))
(incf (arg-state-fpr-args state))
;; Assign outgoing FPRs starting at FP1
(my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
((< fprs 13)
;; According to PowerOpen ABI, we need to pass those both in the
;; FPRs _and_ the stack. However empiric testing on OS X/gcc
;; shows they are only passed in FPRs, AFAICT.
(incf (arg-state-stack-frame-size state) 2)
(incf (arg-state-fpr-args state))
(my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
(t
;; Pass on stack only
(let ((stack-offset (arg-state-stack-frame-size state)))
(incf (arg-state-stack-frame-size state) 2)
(my-make-wired-tn 'double-float 'double-stack stack-offset))))))
;;; Result state handling
(defstruct result-state
(num-results 0))
(defun result-reg-offset (slot)
(ecase slot
(0 nl0-offset)
(1 nl1-offset)))
;;; FIXME: These #!-DARWIN methods should be adjusted to take a state
;;; argument, firstly because that's our "official" API (see
;;; src/code/host-alieneval) and secondly because that way we can
;;; probably have less duplication of code. -- CSR, 2003-07-29
#!-darwin
(define-alien-type-method (system-area-pointer :result-tn) (type)
(declare (ignore type))
(my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
#!+darwin
(define-alien-type-method (system-area-pointer :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'system-area-pointer 'sap-reg
(result-reg-offset num-results))))
#!-darwin
(define-alien-type-method (single-float :result-tn) (type)
(declare (ignore type state))
(my-make-wired-tn 'single-float 'single-reg 1))
#!+darwin
(define-alien-type-method (single-float :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'single-float 'single-reg 1))
#!-darwin
(define-alien-type-method (double-float :result-tn) (type)
(declare (ignore type))
(my-make-wired-tn 'double-float 'double-reg 1))
#!+darwin
(define-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'double-float 'double-reg 1))
#!-darwin
(define-alien-type-method (values :result-tn) (type)
(mapcar #'(lambda (type)
(invoke-alien-type-method :result-tn type))
(alien-values-type-values type)))
#!+darwin
(define-alien-type-method (values :result-tn) (type state)
(let ((values (alien-values-type-values type)))
(when (> (length values) 2)
(error "Too many result values from c-call."))
(mapcar #'(lambda (type)
(invoke-alien-type-method :result-tn type state))
values)))
#!-darwin
(define-alien-type-method (integer :result-tn) (type)
(if (alien-integer-type-signed type)
(my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
(my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
#!+darwin
(define-alien-type-method (integer :result-tn) (type state)
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(multiple-value-bind (ptype reg-sc)
(if (alien-integer-type-signed type)
(values 'signed-byte-32 'signed-reg)
(values 'unsigned-byte-32 'unsigned-reg))
(my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
(!def-vm-support-routine make-call-out-tns (type)
(declare (type alien-fun-type type))
(let ((arg-state (make-arg-state)))
(collect ((arg-tns))
(dolist (arg-type (alien-fun-type-arg-types type))
(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
(* (arg-state-stack-frame-size arg-state) n-word-bytes)
(arg-tns)
(invoke-alien-type-method
:result-tn
(alien-fun-type-result-type type)
#!+darwin (make-result-state))))))
#!+darwin
(deftransform %alien-funcall ((function type &rest args))
(assert (sb!c::constant-lvar-p type))
(let* ((type (sb!c::lvar-value type))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(assert (= (length arg-types) (length args)))
;; We need to do something special for 64-bit integer arguments
;; and results.
(if (or (some #'(lambda (type)
(and (alien-integer-type-p type)
(> (sb!alien::alien-integer-type-bits type) 32)))
arg-types)
(and (alien-integer-type-p result-type)
(> (sb!alien::alien-integer-type-bits result-type) 32)))
(collect ((new-args) (lambda-vars) (new-arg-types))
(dolist (type arg-types)
(let ((arg (gensym)))
(lambda-vars arg)
(cond ((and (alien-integer-type-p type)
(> (sb!alien::alien-integer-type-bits type) 32))
;; 64-bit long long types are stored in
;; consecutive locations, most significant word
;; first (big-endian).
(new-args `(ash ,arg -32))
(new-args `(logand ,arg #xffffffff))
(if (alien-integer-type-signed type)
(new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
(new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
(new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
(t
(new-args arg)
(new-arg-types type)))))
(cond ((and (alien-integer-type-p result-type)
(> (sb!alien::alien-integer-type-bits result-type) 32))
(let ((new-result-type
(let ((sb!alien::*values-type-okay* t))
(parse-alien-type
(if (alien-integer-type-signed result-type)
'(values (signed 32) (unsigned 32))
'(values (unsigned 32) (unsigned 32)))
(sb!kernel:make-null-lexenv)))))
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(multiple-value-bind (high low)
(%alien-funcall function
',(make-alien-fun-type
:arg-types (new-arg-types)
:result-type new-result-type)
,@(new-args))
(logior low (ash high 32))))))
(t
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(%alien-funcall function
',(make-alien-fun-type
:arg-types (new-arg-types)
:result-type result-type)
,@(new-args))))))
(sb!c::give-up-ir1-transform))))
(define-vop (foreign-symbol-address)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
(inst lr res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
#!+linkage-table
(define-vop (foreign-symbol-dataref-address)
(:translate foreign-symbol-dataref-address)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:temporary (:scs (non-descriptor-reg)) addr)
(:generator 2
(inst lr addr (make-fixup (extern-alien-name foreign-symbol)
:foreign-dataref))
(loadw res addr)))
(define-vop (call-out)
(:args (function :scs (sap-reg) :target cfunc)
(args :more t))
(:results (results :more t))
(:ignore args results)
(:save-p t)
(:temporary (:sc any-reg :offset cfunc-offset
:from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:scs (non-descriptor-reg)) temp)
(:vop-var vop)
(:generator 0
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(inst lr temp (make-fixup (extern-alien-name "call_into_c") :foreign))
(inst mtctr temp)
(move cfunc function)
(inst bctrl)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
(define-vop (alloc-number-stack-space)
(:info amount)
(:results (result :scs (sap-reg any-reg)))
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:generator 0
(unless (zerop amount)
;; FIXME: I don't understand why we seem to be adding
;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
;; 2003-08-20
(let ((delta (- (logandc2 (+ amount number-stack-displacement
+stack-alignment-bytes+)
+stack-alignment-bytes+))))
(cond ((>= delta (ash -1 16))
(inst stwu nsp-tn nsp-tn delta))
(t
(inst lr temp delta)
(inst stwux nsp-tn nsp-tn temp)))))
(unless (location= result nsp-tn)
;; They are only location= when the result tn was allocated by
;; make-call-out-tns above, which takes the number-stack-displacement
;; into account itself.
(inst addi result nsp-tn number-stack-displacement))))
(define-vop (dealloc-number-stack-space)
(:info amount)
(:policy :fast-safe)
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount number-stack-displacement
+stack-alignment-bytes+)
+stack-alignment-bytes+)))
(cond ((< delta (ash 1 16))
(inst addi nsp-tn nsp-tn delta))
(t
(inst lwz nsp-tn nsp-tn 0)))))))