69a5d31e955ab37e82e53b973b10f299e43c874b
[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 (defun my-make-wired-tn (prim-type-name sc-name offset)
15   (make-wired-tn (primitive-type-or-lose prim-type-name)
16                  (sc-number-or-lose sc-name)
17                  offset))
18
19 (defstruct arg-state
20   (args 0))
21
22 (defstruct (arg-info
23             (:constructor make-arg-info (offset prim-type reg-sc stack-sc)))
24   offset
25   prim-type
26   reg-sc
27   stack-sc)
28
29 (define-alien-type-method (integer :arg-tn) (type state)
30   (let ((args (arg-state-args state)))
31     (setf (arg-state-args state) (1+ args))
32     (if (alien-integer-type-signed type)
33         (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack)
34         (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))))
35
36 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
37   (declare (ignore type))
38   (let ((args (arg-state-args state)))
39     (setf (arg-state-args state) (1+ args))
40     (make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack)))
41
42 (define-alien-type-method (single-float :arg-tn) (type state)
43   (declare (ignore type))
44   (let ((args (arg-state-args state)))
45     (setf (arg-state-args state) (1+ args))
46     (make-arg-info args 'single-float 'single-reg 'single-stack)))
47
48 (define-alien-type-method (double-float :arg-tn) (type state)
49   (declare (ignore type))
50   (let ((args (logior (1+ (arg-state-args state)) 1)))
51     (setf (arg-state-args state) (1+ args))
52     (make-arg-info args 'double-float 'double-reg 'double-stack)))
53
54 (define-alien-type-method (integer :result-tn) (type)
55   (if (alien-integer-type-signed type)
56       (my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset)
57       (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset)))
58
59 (define-alien-type-method (system-area-pointer :result-tn) (type)
60   (declare (ignore type))
61   (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset))
62
63 (define-alien-type-method (single-float :result-tn) (type)
64   (declare (ignore type))
65   (my-make-wired-tn 'single-float 'single-reg 4))
66
67 (define-alien-type-method (double-float :result-tn) (type)
68   (declare (ignore type))
69   (my-make-wired-tn 'double-float 'double-reg 4))
70
71 (define-alien-type-method (values :result-tn) (type)
72   (let ((values (alien-values-type-values type)))
73     (when values
74       (aver (null (cdr values)))
75       (invoke-alien-type-method :result-tn (car values)))))
76
77 (defun make-arg-tns (type)
78   (let* ((state (make-arg-state))
79          (args (mapcar #'(lambda (arg-type)
80                            (invoke-alien-type-method :arg-tn arg-type state))
81                        (alien-fun-type-arg-types type)))
82          ;; We need 8 words of cruft, and we need to round up to a multiple
83          ;; of 16 words.
84          (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
85     (values
86      (mapcar #'(lambda (arg)
87                  (declare (type arg-info arg))
88                  (let ((offset (arg-info-offset arg))
89                        (prim-type (arg-info-prim-type arg)))
90                    (cond ((>= offset 4)
91                           (my-make-wired-tn prim-type (arg-info-stack-sc arg)
92                                             (- frame-size offset 8 1)))
93                          ((or (eq prim-type 'single-float)
94                               (eq prim-type 'double-float))
95                           (my-make-wired-tn prim-type (arg-info-reg-sc arg)
96                                             (+ offset 4)))
97                          (t
98                           (my-make-wired-tn prim-type (arg-info-reg-sc arg)
99                                             (- nl0-offset offset))))))
100              args)
101      (* frame-size n-word-bytes))))
102
103 (!def-vm-support-routine make-call-out-tns (type)
104   (declare (type alien-fun-type type))
105   (multiple-value-bind
106       (arg-tns stack-size)
107       (make-arg-tns type)
108     (values (make-normal-tn *fixnum-primitive-type*)
109             stack-size
110             arg-tns
111             (invoke-alien-type-method
112              :result-tn
113              (alien-fun-type-result-type type)))))
114
115 (define-vop (foreign-symbol-sap)
116   (:translate foreign-symbol-sap)
117   (:policy :fast-safe)
118   (:args)
119   (:arg-types (:constant simple-string))
120   (:info foreign-symbol)
121   (:results (res :scs (sap-reg)))
122   (:result-types system-area-pointer)
123   (:generator 2
124     (inst li (make-fixup foreign-symbol :foreign) res)))
125
126 (define-vop (call-out)
127   (:args (function :scs (sap-reg) :target cfunc)
128          (args :more t))
129   (:results (results :more t))
130   (:ignore args results)
131   (:save-p t)
132   (:temporary (:sc any-reg :offset cfunc-offset
133                    :from (:argument 0) :to (:result 0)) cfunc)
134   (:temporary (:scs (any-reg) :to (:result 0)) temp)
135   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
136   (:vop-var vop)
137   (:generator 0
138     (let ((cur-nfp (current-nfp-tn vop)))
139       (when cur-nfp
140         (store-stack-tn nfp-save cur-nfp))
141       (move function cfunc)
142       (let ((fixup (make-fixup "call_into_c" :foreign)))
143         (inst ldil fixup temp)
144         (inst ble fixup c-text-space temp :nullify t))
145       (inst nop)
146       (when cur-nfp
147         (load-stack-tn cur-nfp nfp-save)))))
148
149 (define-vop (alloc-number-stack-space)
150   (:info amount)
151   (:results (result :scs (sap-reg any-reg)))
152   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
153   (:generator 0
154     (move nsp-tn result)
155     (unless (zerop amount)
156       (let ((delta (logandc2 (+ amount 63) 63)))
157         (cond ((< delta (ash 1 10))
158                (inst addi delta nsp-tn nsp-tn))
159               (t
160                (inst li delta temp)
161                (inst add temp nsp-tn nsp-tn)))))))
162
163 (define-vop (dealloc-number-stack-space)
164   (:info amount)
165   (:policy :fast-safe)
166   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
167   (:generator 0
168     (unless (zerop amount)
169       (let ((delta (- (logandc2 (+ amount 63) 63))))
170         (cond ((<= (- (ash 1 10)) delta)
171                (inst addi delta nsp-tn nsp-tn))
172               (t
173                (inst li delta temp)
174                (inst add temp nsp-tn nsp-tn)))))))