1029ee9feecb42a1ea948c333c5d62d08ddc078b
[sbcl.git] / src / compiler / hppa / 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 ;;; beware that we deal alot here with register-offsets directly
15 ;;; instead of their symbol-name in vm.lisp
16 ;;; offset works differently depending on sc-type
17 (defun my-make-wired-tn (prim-type-name sc-name offset state)
18   (make-wired-tn (primitive-type-or-lose prim-type-name)
19                  (sc-number-or-lose sc-name)
20                  ;; try to utilize vm.lisp definitions of registers:
21                  (ecase sc-name
22                    ((any-reg sap-reg signed-reg unsigned-reg)
23                      (ecase offset ; FIX: port to other arch ???
24                        ;(:nfp-offset offset)
25                        (0 nl0-offset) ; On other arch we can
26                        (1 nl1-offset) ; just add an offset to
27                        (2 nl2-offset) ; beginning of args, but on
28                        (3 nl3-offset) ; hppa c-args are spread.
29                        (4 nl4-offset) ; These two are for
30                        (5 nl5-offset))) ; c-return values
31                    ((single-int-carg-reg double-int-carg-reg)
32                      (ecase offset ; FIX: port to other arch ???
33                        (0 nl0-offset)
34                        (1 nl1-offset)
35                        (2 nl2-offset)
36                        (3 nl3-offset)))
37                    ((single-reg double-reg) ; only for return
38                      (+ 4 offset))
39                    ;; A tn of stack type tells us that we have data on
40                    ;; stack. This offset is current argument number so
41                    ;; -1 points to the correct place to write that data
42                    ((sap-stack signed-stack unsigned-stack)
43                      (- (arg-state-nargs state) offset 8 1)))))
44
45 (defstruct arg-state
46   (stack-frame-size 0)
47   (float-args 0)
48   nargs)
49
50 (define-alien-type-method (integer :arg-tn) (type state)
51   (let ((stack-frame-size (arg-state-stack-frame-size state)))
52     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
53     (multiple-value-bind
54       (ptype reg-sc stack-sc)
55       (if (alien-integer-type-signed type)
56         (values 'signed-byte-32 'signed-reg 'signed-stack)
57         (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
58       (if (< stack-frame-size 4)
59         (my-make-wired-tn ptype reg-sc stack-frame-size state)
60         (my-make-wired-tn ptype stack-sc stack-frame-size state)))))
61
62 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
63   (declare (ignore type))
64   (let ((stack-frame-size (arg-state-stack-frame-size state)))
65     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
66     (if (< stack-frame-size 4)
67       (my-make-wired-tn 'system-area-pointer
68                         'sap-reg
69                         stack-frame-size state)
70       (my-make-wired-tn 'system-area-pointer
71                         'sap-stack
72                         stack-frame-size state))))
73
74 (define-alien-type-method (double-float :arg-tn) (type state)
75   (declare (ignore type))
76   (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
77         (float-args (arg-state-float-args state)))
78     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
79     (setf (arg-state-float-args state) (1+ float-args))
80     (cond ((>= stack-frame-size 4)
81            (my-make-wired-tn 'double-float
82                              'double-stack
83                              stack-frame-size state))
84           (t
85             (my-make-wired-tn 'double-float
86                               'double-int-carg-reg
87                               (1+ (* float-args 2)) state)))))
88
89 (define-alien-type-method (single-float :arg-tn) (type state)
90   (declare (ignore type))
91   (let ((stack-frame-size (arg-state-stack-frame-size state))
92         (float-args (arg-state-float-args state)))
93     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
94     (setf (arg-state-float-args state) (1+ float-args))
95     (cond ((>= stack-frame-size 4)
96            (my-make-wired-tn 'single-float
97                              'single-stack
98                              stack-frame-size state))
99           (t
100             (my-make-wired-tn 'double-float
101                               'single-int-carg-reg
102                               (* float-args 2) state)))))
103
104 (defstruct result-state
105   (num-results 0))
106
107 (define-alien-type-method (integer :result-tn) (type state)
108   (let ((num-results (result-state-num-results state)))
109     (setf (result-state-num-results state) (1+ num-results))
110     (multiple-value-bind (ptype reg-sc)
111       (if (alien-integer-type-signed type)
112         (values 'signed-byte-32 'signed-reg)
113         (values 'unsigned-byte-32 'unsigned-reg))
114       (if (> num-results 1) (error "Too many result values from c-call."))
115       (my-make-wired-tn ptype reg-sc (+ num-results 4) state))))
116
117 (define-alien-type-method (system-area-pointer :result-tn) (type state)
118   (declare (ignore type))
119   (let ((num-results (result-state-num-results state)))
120     (setf (result-state-num-results state) (1+ num-results))
121     (if (> num-results 1) (error "Too many result values from c-call."))
122     (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 4) state)))
123
124 (define-alien-type-method (double-float :result-tn) (type state)
125   (declare (ignore type))
126   (let ((num-results (result-state-num-results state)))
127     (setf (result-state-num-results state) (1+ num-results))
128     (my-make-wired-tn 'double-float 'double-reg (* num-results 2) state)))
129
130 (define-alien-type-method (single-float :result-tn) (type state)
131   (declare (ignore type))
132   (let ((num-results (result-state-num-results state)))
133     (setf (result-state-num-results state) (1+ num-results))
134     (my-make-wired-tn 'single-float 'single-reg (* num-results 2) state)))
135
136 (define-alien-type-method (values :result-tn) (type state)
137   (let ((values (alien-values-type-values type)))
138     (when (> (length values) 2)
139       (error "Too many result values from c-call."))
140     (mapcar (lambda (type)
141               (invoke-alien-type-method :result-tn type state))
142             values)))
143
144 (defun make-call-out-tns (type)
145   (let ((arg-state (make-arg-state))
146         (nargs 0))
147     (dolist (arg-type (alien-fun-type-arg-types type))
148       (cond
149         ((alien-double-float-type-p arg-type)
150           (incf nargs (logior (1+ nargs) 1)))
151         (t (incf nargs))))
152     (setf (arg-state-nargs arg-state) (logandc2 (+ nargs 8 15) 15))
153     (collect ((arg-tns))
154       (dolist (arg-type (alien-fun-type-arg-types type))
155         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
156       (values (make-normal-tn *fixnum-primitive-type*)
157               (* n-word-bytes (logandc2 (+ nargs 8 15) 15))
158               (arg-tns)
159               (invoke-alien-type-method :result-tn
160                                         (alien-fun-type-result-type type)
161                                         (make-result-state))))))
162
163 (deftransform %alien-funcall ((function type &rest args))
164   (aver (sb!c::constant-lvar-p type))
165   (let* ((type (sb!c::lvar-value type))
166          (env (sb!kernel:make-null-lexenv))
167          (arg-types (alien-fun-type-arg-types type))
168          (result-type (alien-fun-type-result-type type)))
169     (aver (= (length arg-types) (length args)))
170     ;; We need to do something special for 64-bit integer arguments
171     ;; and results.
172     (if (or (some (lambda (type)
173                     (and (alien-integer-type-p type)
174                          (> (sb!alien::alien-integer-type-bits type) 32)))
175                   arg-types)
176             (and (alien-integer-type-p result-type)
177                  (> (sb!alien::alien-integer-type-bits result-type) 32)))
178         (collect ((new-args) (lambda-vars) (new-arg-types))
179                  (dolist (type arg-types)
180                    (let ((arg (gensym)))
181                      (lambda-vars arg)
182                      (cond ((and (alien-integer-type-p type)
183                                  (> (sb!alien::alien-integer-type-bits type) 32))
184                             ;; 64-bit long long types are stored in
185                             ;; consecutive locations, endian word order,
186                             ;; aligned to 8 bytes.
187                             (when (oddp (length (new-args)))
188                               (new-args nil))
189                             (progn (new-args `(ash ,arg -32))
190                                    (new-args `(logand ,arg #xffffffff))
191                                    (if (oddp (length (new-arg-types)))
192                                        (new-arg-types (parse-alien-type '(unsigned 32) env)))
193                                    (if (alien-integer-type-signed type)
194                                        (new-arg-types (parse-alien-type '(signed 32) env))
195                                        (new-arg-types (parse-alien-type '(unsigned 32) env)))
196                                    (new-arg-types (parse-alien-type '(unsigned 32) env))))
197                            (t
198                             (new-args arg)
199                             (new-arg-types type)))))
200                  (cond ((and (alien-integer-type-p result-type)
201                              (> (sb!alien::alien-integer-type-bits result-type) 32))
202                         (let ((new-result-type
203                                (let ((sb!alien::*values-type-okay* t))
204                                  (parse-alien-type
205                                   (if (alien-integer-type-signed result-type)
206                                       '(values (signed 32) (unsigned 32))
207                                       '(values (unsigned 32) (unsigned 32)))
208                                   env))))
209                           `(lambda (function type ,@(lambda-vars))
210                             (declare (ignore type))
211                              (multiple-value-bind
212                                (high low)
213                                (%alien-funcall function
214                                   ',(make-alien-fun-type
215                                        :arg-types (new-arg-types)
216                                        :result-type new-result-type)
217                                   ,@(new-args))
218                                (logior low (ash high 32))))))
219                        (t
220                         `(lambda (function type ,@(lambda-vars))
221                           (declare (ignore type))
222                           (%alien-funcall function
223                            ',(make-alien-fun-type
224                               :arg-types (new-arg-types)
225                               :result-type result-type)
226                            ,@(new-args))))))
227         (sb!c::give-up-ir1-transform))))
228
229 (define-vop (foreign-symbol-sap)
230   (:translate foreign-symbol-sap)
231   (:policy :fast-safe)
232   (:args)
233   (:arg-types (:constant simple-string))
234   (:info foreign-symbol)
235   (:results (res :scs (sap-reg)))
236   (:result-types system-area-pointer)
237   (:generator 2
238     (inst li (make-fixup foreign-symbol :foreign) res)))
239
240 #!+linkage-table
241 (define-vop (foreign-symbol-dataref-sap)
242   (:translate foreign-symbol-dataref-sap)
243   (:policy :fast-safe)
244   (:args)
245   (:arg-types (:constant simple-string))
246   (:info foreign-symbol)
247   (:results (res :scs (sap-reg)))
248   (:result-types system-area-pointer)
249   (:temporary (:scs (non-descriptor-reg)) addr)
250   (:generator 2
251     (inst li (make-fixup foreign-symbol :foreign-dataref) addr)
252     (loadw res addr)))
253
254 (define-vop (call-out)
255   (:args (function :scs (sap-reg) :target cfunc)
256          (args :more t))
257   (:results (results :more t))
258   (:ignore args results)
259   (:save-p t)
260   (:temporary (:sc any-reg :offset cfunc-offset
261                    :from (:argument 0) :to (:result 0)) cfunc)
262   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
263   ;; Not sure if using nargs is safe ( have we saved it ).
264   ;; but we cant use any non-descriptor-reg because c-args nl-4 is of that type
265   (:temporary (:sc non-descriptor-reg :offset nargs-offset) temp)
266   (:vop-var vop)
267   (:generator 0
268     (let ((cur-nfp (current-nfp-tn vop)))
269       (when cur-nfp
270         (store-stack-tn nfp-save cur-nfp))
271       (let ((fixup (make-fixup "call_into_c" :foreign)))
272         (inst ldil fixup temp)
273         (inst ble fixup c-text-space temp)
274         (move function cfunc t))
275       (when cur-nfp
276         (load-stack-tn cur-nfp nfp-save)))))
277
278 (define-vop (alloc-number-stack-space)
279   (:info amount)
280   (:result-types system-area-pointer)
281   (:results (result :scs (sap-reg any-reg)))
282   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
283   (:generator 0
284     ;; Because stack grows to higher addresses, we have the result
285     ;; pointing to an lowerer address than nsp
286     (move nsp-tn result)
287     (unless (zerop amount)
288       ;; hp-ux stack grows towards larger addresses and stack must be
289       ;; allocated in blocks of 64 bytes
290       (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16
291         (cond ((< delta (ash 1 10))
292                (inst addi delta nsp-tn nsp-tn))
293               (t
294                (inst li delta temp)
295                (inst add nsp-tn temp nsp-tn)))))))
296
297 (define-vop (dealloc-number-stack-space)
298   (:info amount)
299   (:policy :fast-safe)
300   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
301   (:generator 0
302     (unless (zerop amount)
303       (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16
304         (cond ((< delta (ash 1 10))
305                (inst addi (- delta) nsp-tn nsp-tn))
306               (t
307                (inst li (- delta) temp)
308                (inst sub nsp-tn temp nsp-tn)))))))
309
310 #-sb-xc-host
311 (defun alien-callback-accessor-form (type sap offset)
312   (let ((parsed-type type))
313     (if (alien-integer-type-p parsed-type)
314         (let ((bits (sb!alien::alien-integer-type-bits parsed-type)))
315                (let ((byte-offset
316                       (cond ((< bits n-word-bits)
317                              (- n-word-bytes
318                                 (ceiling bits n-byte-bits)))
319                             (t 0))))
320                  `(deref (sap-alien (sap+ ,sap
321                                           ,(+ byte-offset offset))
322                                     (* ,type)))))
323         `(deref (sap-alien (sap+ ,sap ,offset) (* ,type))))))
324