0.pre7.20:
[sbcl.git] / src / compiler / x86 / c-call.lisp
1 ;;;; the VOPs and other necessary machine specific support
2 ;;;; routines for call-out to C
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!VM")
14
15 ;; The MOVE-ARGUMENT vop is going to store args on the stack for
16 ;; call-out. These tn's will be used for that. move-arg is normally
17 ;; used for things going down the stack but C wants to have args
18 ;; indexed in the positive direction.
19
20 (defun my-make-wired-tn (prim-type-name sc-name offset)
21   (make-wired-tn (primitive-type-or-lose prim-type-name)
22                  (sc-number-or-lose sc-name)
23                  offset))
24
25 (defstruct (arg-state (:copier nil))
26   (stack-frame-size 0))
27
28 (def-alien-type-method (integer :arg-tn) (type state)
29   (let ((stack-frame-size (arg-state-stack-frame-size state)))
30     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
31     (multiple-value-bind (ptype stack-sc)
32         (if (alien-integer-type-signed type)
33             (values 'signed-byte-32 'signed-stack)
34             (values 'unsigned-byte-32 'unsigned-stack))
35       (my-make-wired-tn ptype stack-sc stack-frame-size))))
36
37 (def-alien-type-method (system-area-pointer :arg-tn) (type state)
38   (declare (ignore type))
39   (let ((stack-frame-size (arg-state-stack-frame-size state)))
40     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
41     (my-make-wired-tn 'system-area-pointer
42                       'sap-stack
43                       stack-frame-size)))
44
45 #!+long-float
46 (def-alien-type-method (long-float :arg-tn) (type state)
47   (declare (ignore type))
48   (let ((stack-frame-size (arg-state-stack-frame-size state)))
49     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 3))
50     (my-make-wired-tn 'long-float 'long-stack stack-frame-size)))
51
52 (def-alien-type-method (double-float :arg-tn) (type state)
53   (declare (ignore type))
54   (let ((stack-frame-size (arg-state-stack-frame-size state)))
55     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
56     (my-make-wired-tn 'double-float 'double-stack stack-frame-size)))
57
58 (def-alien-type-method (single-float :arg-tn) (type state)
59   (declare (ignore type))
60   (let ((stack-frame-size (arg-state-stack-frame-size state)))
61     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
62     (my-make-wired-tn 'single-float 'single-stack stack-frame-size)))
63
64 (defstruct (result-state (:copier nil))
65   (num-results 0))
66
67 (defun result-reg-offset (slot)
68   (ecase slot
69     (0 eax-offset)
70     (1 edx-offset)))
71
72 (def-alien-type-method (integer :result-tn) (type state)
73   (let ((num-results (result-state-num-results state)))
74     (setf (result-state-num-results state) (1+ num-results))
75     (multiple-value-bind (ptype reg-sc)
76         (if (alien-integer-type-signed type)
77             (values 'signed-byte-32 'signed-reg)
78             (values 'unsigned-byte-32 'unsigned-reg))
79       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
80
81 (def-alien-type-method (system-area-pointer :result-tn) (type state)
82   (declare (ignore type))
83   (let ((num-results (result-state-num-results state)))
84     (setf (result-state-num-results state) (1+ num-results))
85     (my-make-wired-tn 'system-area-pointer 'sap-reg
86                       (result-reg-offset num-results))))
87
88 #!+long-float
89 (def-alien-type-method (long-float :result-tn) (type state)
90   (declare (ignore type))
91   (let ((num-results (result-state-num-results state)))
92     (setf (result-state-num-results state) (1+ num-results))
93     (my-make-wired-tn 'long-float 'long-reg (* num-results 2))))
94
95 (def-alien-type-method (double-float :result-tn) (type state)
96   (declare (ignore type))
97   (let ((num-results (result-state-num-results state)))
98     (setf (result-state-num-results state) (1+ num-results))
99     (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
100
101 (def-alien-type-method (single-float :result-tn) (type state)
102   (declare (ignore type))
103   (let ((num-results (result-state-num-results state)))
104     (setf (result-state-num-results state) (1+ num-results))
105     (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
106
107 #+nil ;;pfw obsolete now?
108 (def-alien-type-method (values :result-tn) (type state)
109   (mapcar #'(lambda (type)
110               (invoke-alien-type-method :result-tn type state))
111           (alien-values-type-values type)))
112
113 ;;; pfw - from alpha
114 (def-alien-type-method (values :result-tn) (type state)
115   (let ((values (alien-values-type-values type)))
116     (when (cdr values)
117       (error "Too many result values from c-call."))
118     (when values
119       (invoke-alien-type-method :result-tn (car values) state))))
120
121 (!def-vm-support-routine make-call-out-tns (type)
122   (let ((arg-state (make-arg-state)))
123     (collect ((arg-tns))
124       (dolist #+nil ;; this reversed list seems to cause the alien botches!!
125         (arg-type (reverse (alien-function-type-arg-types type)))
126         (arg-type (alien-function-type-arg-types type))
127         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
128       (values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
129               (* (arg-state-stack-frame-size arg-state) word-bytes)
130               (arg-tns)
131               (invoke-alien-type-method :result-tn
132                                         (alien-function-type-result-type type)
133                                         (make-result-state))))))
134
135 (define-vop (foreign-symbol-address)
136   (:translate foreign-symbol-address)
137   (:policy :fast-safe)
138   (:args)
139   (:arg-types (:constant simple-string))
140   (:info foreign-symbol)
141   (:results (res :scs (sap-reg)))
142   (:result-types system-area-pointer)
143   (:generator 2
144    (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
145
146 (define-vop (call-out)
147   (:args (function :scs (sap-reg))
148          (args :more t))
149   (:results (results :more t))
150   ;; eax is already wired
151   (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
152   (:temporary (:sc unsigned-reg :offset edx-offset) edx)
153   (:node-var node)
154   (:vop-var vop)
155   (:save-p t)
156   (:ignore args ecx edx)
157   (:generator 0
158     (cond ((policy node (> space speed))
159            (move eax-tn function)
160            (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
161           (t
162            ;; Setup the NPX for C; all the FP registers need to be
163            ;; empty; pop them all.
164            (inst fstp fr0-tn)
165            (inst fstp fr0-tn)
166            (inst fstp fr0-tn)
167            (inst fstp fr0-tn)
168            (inst fstp fr0-tn)
169            (inst fstp fr0-tn)
170            (inst fstp fr0-tn)
171            (inst fstp fr0-tn)
172
173            (inst call function)
174            ;; To give the debugger a clue. XX not really internal-error?
175            (note-this-location vop :internal-error)
176
177            ;; Restore the NPX for lisp.
178            (inst fldz) ; insure no regs are empty
179            (inst fldz)
180            (inst fldz)
181            (inst fldz)
182            (inst fldz)
183            (inst fldz)
184            (inst fldz)
185
186            (if (and results
187                     (location= (tn-ref-tn results) fr0-tn))
188                ;; The return result is in fr0.
189                (inst fxch fr7-tn) ; move the result back to fr0
190                (inst fldz)) ; insure no regs are empty
191            ))))
192
193 (define-vop (alloc-number-stack-space)
194   (:info amount)
195   (:results (result :scs (sap-reg any-reg)))
196   (:generator 0
197     (aver (location= result esp-tn))
198     (unless (zerop amount)
199       (let ((delta (logandc2 (+ amount 3) 3)))
200         (inst sub esp-tn delta)))
201     (move result esp-tn)))
202
203 (define-vop (dealloc-number-stack-space)
204   (:info amount)
205   (:generator 0
206     (unless (zerop amount)
207       (let ((delta (logandc2 (+ amount 3) 3)))
208         (inst add esp-tn delta)))))
209
210 (define-vop (alloc-alien-stack-space)
211   (:info amount)
212   (:results (result :scs (sap-reg any-reg)))
213   (:generator 0
214     (aver (not (location= result esp-tn)))
215     (unless (zerop amount)
216       (let ((delta (logandc2 (+ amount 3) 3)))
217         (inst sub (make-ea :dword
218                            :disp (+ nil-value
219                                     (static-symbol-offset '*alien-stack*)
220                                     (ash symbol-value-slot word-shift)
221                                     (- other-pointer-type)))
222               delta)))
223     (load-symbol-value result *alien-stack*)))
224
225 (define-vop (dealloc-alien-stack-space)
226   (:info amount)
227   (:generator 0
228     (unless (zerop amount)
229       (let ((delta (logandc2 (+ amount 3) 3)))
230         (inst add (make-ea :dword
231                            :disp (+ nil-value
232                                     (static-symbol-offset '*alien-stack*)
233                                     (ash symbol-value-slot word-shift)
234                                     (- other-pointer-type)))
235               delta)))))