0.7.7.9:
[sbcl.git] / src / compiler / mips / c-call.lisp
1 (in-package "SB!VM")
2
3 (defun my-make-wired-tn (prim-type-name sc-name offset)
4   (make-wired-tn (primitive-type-or-lose prim-type-name)
5                  (sc-number-or-lose sc-name)
6                  offset))
7
8 (defstruct arg-state
9   (stack-frame-size 0)
10   (did-int-arg nil)
11   (float-args 0))
12
13 (define-alien-type-method (integer :arg-tn) (type state)
14   (let ((stack-frame-size (arg-state-stack-frame-size state)))
15     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
16     (setf (arg-state-did-int-arg state) t)
17     (multiple-value-bind
18         (ptype reg-sc stack-sc)
19         (if (alien-integer-type-signed type)
20             (values 'signed-byte-32 'signed-reg 'signed-stack)
21             (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
22       (if (< stack-frame-size 4)
23           (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
24           (my-make-wired-tn ptype stack-sc stack-frame-size)))))
25
26 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
27   (declare (ignore type))
28   (let ((stack-frame-size (arg-state-stack-frame-size state)))
29     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
30     (setf (arg-state-did-int-arg state) t)
31     (if (< stack-frame-size 4)
32         (my-make-wired-tn 'system-area-pointer
33                           'sap-reg
34                           (+ stack-frame-size 4))
35         (my-make-wired-tn 'system-area-pointer
36                           'sap-stack
37                           stack-frame-size))))
38
39 (define-alien-type-method (double-float :arg-tn) (type state)
40   (declare (ignore type))
41   (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
42         (float-args (arg-state-float-args state)))
43     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
44     (setf (arg-state-float-args state) (1+ float-args))
45     (cond ((>= stack-frame-size 4)
46            (my-make-wired-tn 'double-float
47                              'double-stack
48                              stack-frame-size))
49           ((and (not (arg-state-did-int-arg state))
50                 (< float-args 2))
51            (my-make-wired-tn 'double-float
52                              'double-reg
53                              (+ (* float-args 2) 12)))
54           (t
55            (my-make-wired-tn 'double-float
56                              'double-int-carg-reg
57                              (+ stack-frame-size 4))))))
58
59 (define-alien-type-method (single-float :arg-tn) (type state)
60   (declare (ignore type))
61   (let ((stack-frame-size (arg-state-stack-frame-size state))
62         (float-args (arg-state-float-args state)))
63     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
64     (setf (arg-state-float-args state) (1+ float-args))
65     (cond ((>= stack-frame-size 4)
66            (my-make-wired-tn 'single-float
67                              'single-stack
68                              stack-frame-size))
69           ((and (not (arg-state-did-int-arg state))
70                 (< float-args 2))
71            (my-make-wired-tn 'single-float
72                              'single-reg
73                              (+ (* float-args 2) 12)))
74           (t
75            (my-make-wired-tn 'single-float
76                              'single-int-carg-reg
77                              (+ stack-frame-size 4))))))
78
79
80 (defstruct result-state
81   (num-results 0))
82
83 (defun offset-for-result (n)
84   (+ n 2)
85   #+nil
86   (if (= n 0)
87       cfunc-offset
88       (+ n 2)))
89
90 (define-alien-type-method (integer :result-tn) (type state)
91   (let ((num-results (result-state-num-results state)))
92     (setf (result-state-num-results state) (1+ num-results))
93     (multiple-value-bind
94         (ptype reg-sc)
95         (if (alien-integer-type-signed type)
96             (values 'signed-byte-32 'signed-reg)
97             (values 'unsigned-byte-32 'unsigned-reg))
98       (my-make-wired-tn ptype reg-sc (offset-for-result num-results)))))
99
100 (define-alien-type-method (system-area-pointer :result-tn) (type state)
101   (declare (ignore type))
102   (let ((num-results (result-state-num-results state)))
103     (setf (result-state-num-results state) (1+ num-results))
104     (my-make-wired-tn 'system-area-pointer 'sap-reg (offset-for-result num-results))))
105
106 ;;; FIXME: do these still work? -- CSR, 2002-08-28
107 (define-alien-type-method (double-float :result-tn) (type state)
108   (declare (ignore type))
109   (let ((num-results (result-state-num-results state)))
110     (setf (result-state-num-results state) (1+ num-results))
111     (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
112
113 (define-alien-type-method (single-float :result-tn) (type state)
114   (declare (ignore type))
115   (let ((num-results (result-state-num-results state)))
116     (setf (result-state-num-results state) (1+ num-results))
117     (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
118
119 (define-alien-type-method (values :result-tn) (type state)
120   (mapcar #'(lambda (type)
121               (invoke-alien-type-method :result-tn type state))
122           (alien-values-type-values type)))
123
124 (!def-vm-support-routine make-call-out-tns (type)
125   (let ((arg-state (make-arg-state)))
126     (collect ((arg-tns))
127       (dolist (arg-type (alien-fun-type-arg-types type))
128         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
129       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
130               (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes)
131               (arg-tns)
132               (invoke-alien-type-method :result-tn
133                                         (alien-fun-type-result-type type)
134                                         (make-result-state))))))
135
136
137 (define-vop (foreign-symbol-address)
138   (:translate foreign-symbol-address)
139   (:policy :fast-safe)
140   (:args)
141   (:arg-types (:constant simple-string))
142   (:info foreign-symbol)
143   (:results (res :scs (sap-reg)))
144   (:result-types system-area-pointer)
145   (:generator 2
146     (inst li res (make-fixup foreign-symbol :foreign))))
147
148 (define-vop (call-out)
149   (:args (function :scs (sap-reg) :target cfunc)
150          (args :more t))
151   (:results (results :more t))
152   (:ignore args results)
153   (:save-p t)
154   (:temporary (:sc any-reg :offset cfunc-offset
155                    :from (:argument 0) :to (:result 0)) cfunc)
156   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
157   (:vop-var vop)
158   (:generator 0
159     (let ((cur-nfp (current-nfp-tn vop)))
160       (when cur-nfp
161         (store-stack-tn nfp-save cur-nfp))
162       (move cfunc function)
163       (inst jal (make-fixup "call_into_c" :foreign))
164       (inst nop)
165       (when cur-nfp
166         (load-stack-tn cur-nfp nfp-save)))))
167
168 (define-vop (alloc-number-stack-space)
169   (:info amount)
170   (:results (result :scs (sap-reg any-reg)))
171   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
172   (:generator 0
173     (unless (zerop amount)
174       (let ((delta (logandc2 (+ amount 7) 7)))
175         (cond ((< delta (ash 1 15))
176                (inst subu nsp-tn delta))
177               (t
178                (inst li temp delta)
179                (inst subu nsp-tn temp)))))
180     (move result nsp-tn)))
181
182 (define-vop (dealloc-number-stack-space)
183   (:info amount)
184   (:policy :fast-safe)
185   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
186   (:generator 0
187     (unless (zerop amount)
188       (let ((delta (logandc2 (+ amount 7) 7)))
189         (cond ((< delta (ash 1 15))
190                (inst addu nsp-tn delta))
191               (t
192                (inst li temp delta)
193                (inst addu nsp-tn temp)))))))