Cleverer handling of medium (32 < bit width <= 64) constants on x86-64
[sbcl.git] / src / assembly / hppa / assem-rtns.lisp
1 (in-package "SB!VM")
2
3 ;;;; Return-multiple with other than one value
4
5 #+sb-assembling ;; we don't want a vop for this one.
6 (define-assembly-routine
7     (return-multiple
8      (:return-style :none))
9      ;; These four are really arguments.
10     ((:temp nvals any-reg nargs-offset)
11      (:temp vals any-reg nl0-offset)
12      (:temp ocfp any-reg nl1-offset)
13      (:temp lra descriptor-reg lra-offset)
14      ;; These are just needed to facilitate the transfer
15      (:temp count any-reg nl2-offset)
16      (:temp dst any-reg nl3-offset)
17      (:temp temp descriptor-reg l0-offset)
18      ;; These are needed so we can get at the register args.
19      (:temp a0 descriptor-reg a0-offset)
20      (:temp a1 descriptor-reg a1-offset)
21      (:temp a2 descriptor-reg a2-offset)
22      (:temp a3 descriptor-reg a3-offset)
23      (:temp a4 descriptor-reg a4-offset)
24      (:temp a5 descriptor-reg a5-offset))
25   ;; Note, because of the way the return-multiple vop is written, we can
26   ;; assume that we are never called with nvals == 1 and that a0 has already
27   ;; been loaded. ;FIX-lav: look at old hppa , replace comb+addi with addib
28   (inst comb :<= nvals zero-tn DEFAULT-A0-AND-ON)
29   (inst addi (- (fixnumize 2)) nvals count)
30   (inst comb :<= count zero-tn DEFAULT-A2-AND-ON)
31   (inst ldw (* 1 n-word-bytes) vals a1)
32   (inst addib :<= (- (fixnumize 1)) count DEFAULT-A3-AND-ON)
33   (inst ldw (* 2 n-word-bytes) vals a2)
34   (inst addib :<= (- (fixnumize 1)) count DEFAULT-A4-AND-ON)
35   (inst ldw (* 3 n-word-bytes) vals a3)
36   (inst addib :<= (- (fixnumize 1)) count DEFAULT-A5-AND-ON)
37   (inst ldw (* 4 n-word-bytes) vals a4)
38   (inst addib :<= (- (fixnumize 1)) count done)
39   (inst ldw (* 5 n-word-bytes) vals a5)
40   ;; Copy the remaining args to the top of the stack.
41   (inst addi (fixnumize register-arg-count) vals vals)
42   (inst addi (fixnumize register-arg-count) cfp-tn dst)
43   LOOP
44   (inst ldwm n-word-bytes vals temp)
45   (inst addib :<> (- (fixnumize 1)) count LOOP)
46   (inst stwm temp n-word-bytes dst)
47   (inst b DONE :nullify t)
48
49   DEFAULT-A0-AND-ON
50   (move null-tn a0)
51   (move null-tn a1)
52   DEFAULT-A2-AND-ON
53   (move null-tn a2)
54   DEFAULT-A3-AND-ON
55   (move null-tn a3)
56   DEFAULT-A4-AND-ON
57   (move null-tn a4)
58   DEFAULT-A5-AND-ON
59   (move null-tn a5)
60   DONE
61   ;; Clear the stack.
62   (move cfp-tn ocfp-tn)
63   (move ocfp cfp-tn)
64   (inst add ocfp-tn nvals csp-tn)
65   (lisp-return lra))
66
67 \f
68 ;;;; tail-call-variable.
69
70 #+sb-assembling ;; no vop for this one either.
71 (define-assembly-routine
72     (tail-call-variable
73      (:return-style :none))
74     ;; These are really args.
75     ((:temp args any-reg nl0-offset)
76      (:temp lexenv descriptor-reg lexenv-offset)
77      ;; We need to compute this
78      (:temp nargs any-reg nargs-offset)
79      ;; These are needed by the blitting code.
80      (:temp src any-reg nl1-offset)
81      (:temp dst any-reg nl2-offset)
82      (:temp count any-reg nl3-offset)
83      (:temp temp descriptor-reg l0-offset)
84      ;; These are needed so we can get at the register args.
85      (:temp a0 descriptor-reg a0-offset)
86      (:temp a1 descriptor-reg a1-offset)
87      (:temp a2 descriptor-reg a2-offset)
88      (:temp a3 descriptor-reg a3-offset)
89      (:temp a4 descriptor-reg a4-offset)
90      (:temp a5 descriptor-reg a5-offset))
91   ;; Calculate NARGS (as a fixnum)
92   (inst sub csp-tn args nargs)
93   ;; Load the argument regs (must do this now, 'cause the blt might
94   ;; trash these locations)
95   (loadw a0 args 0)
96   (loadw a1 args 1)
97   (loadw a2 args 2)
98   (loadw a3 args 3)
99   (loadw a4 args 4)
100   (loadw a5 args 5)
101   ;; Calc SRC, DST, and COUNT
102   (inst addi (- (fixnumize register-arg-count)) nargs count)
103   (inst comb :<= count zero-tn done)
104   (inst addi (fixnumize register-arg-count) args src)
105   (inst addi (fixnumize register-arg-count) cfp-tn dst)
106   LOOP
107   ;; Copy one arg and increase src
108   (inst ldwm n-word-bytes src temp)
109   (inst addib :<> (- (fixnumize 1)) count LOOP)
110   (inst stwm temp n-word-bytes dst)
111   DONE
112   ;; We are done.  Do the jump.
113   (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
114   (lisp-jump temp))
115
116 \f
117 ;;;; Non-local exit noise.
118
119 (define-assembly-routine
120     (unwind
121      (:translate %continue-unwind)
122      (:return-style :none)
123      (:policy :fast-safe))
124     ((:arg block (any-reg descriptor-reg) a0-offset)
125      (:arg start (any-reg descriptor-reg) ocfp-offset)
126      (:arg count (any-reg descriptor-reg) nargs-offset)
127      (:temp lra descriptor-reg lra-offset)
128      (:temp cur-uwp any-reg nl0-offset)
129      (:temp next-uwp any-reg nl1-offset)
130      (:temp target-uwp any-reg nl2-offset))
131   (declare (ignore start count))
132
133
134   (let ((error (generate-error-code nil invalid-unwind-error)))
135     (inst bc := nil block zero-tn error))
136
137   (load-symbol-value cur-uwp *current-unwind-protect-block*)
138   (loadw target-uwp block unwind-block-current-uwp-slot)
139   (inst bc :<> nil cur-uwp target-uwp DO-UWP)
140
141   (move block cur-uwp)
142
143   DO-EXIT
144   (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
145   (loadw code-tn cur-uwp unwind-block-current-code-slot)
146   (loadw lra cur-uwp unwind-block-entry-pc-slot)
147   (lisp-return lra :frob-code nil)
148
149   DO-UWP
150   (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
151   (inst b DO-EXIT)
152   (store-symbol-value next-uwp *current-unwind-protect-block*))
153
154 (define-assembly-routine
155     (throw
156      (:return-style :none))
157     ((:arg target descriptor-reg a0-offset)
158      (:arg start any-reg ocfp-offset)
159      (:arg count any-reg nargs-offset)
160      (:temp catch any-reg a1-offset)
161      (:temp tag descriptor-reg a2-offset)
162      (:temp fix descriptor-reg nl0-offset))
163   (declare (ignore start count)) ; We just need them in the registers.
164
165   (load-symbol-value catch *current-catch-block*)
166
167   LOOP
168   (let ((error (generate-error-code nil unseen-throw-tag-error target)))
169     (inst bc := nil catch zero-tn error))
170   (loadw tag catch catch-block-tag-slot)
171   (inst comb := tag target EXIT :nullify t)
172   (inst b LOOP)
173   (loadw catch catch catch-block-previous-catch-slot)
174   EXIT
175   (let ((fixup (make-fixup 'unwind :assembly-routine)))
176     (inst ldil fixup fix)
177     (inst ble fixup lisp-heap-space fix))
178   (move catch target t))
179
180 ; we need closure-tramp and funcallable-instance-tramp in
181 ; same space as other lisp-code, because caller is doing
182 ; normal lisp-calls where we doesnt specify space.
183 ; if we doesnt have the lisp-function (code from defun, closure, lambda etc..)
184 ; machine-address, resolve it here and jump to it.
185 (define-assembly-routine
186   (closure-tramp (:return-style :none))
187   ((:temp lip interior-reg lip-offset)
188    (:temp nl0 descriptor-reg nl0-offset))
189   (inst ldw (- (* fdefn-fun-slot n-word-bytes)
190                other-pointer-lowtag)
191             fdefn-tn lexenv-tn)
192   (inst ldw (- (* closure-fun-slot n-word-bytes)
193                   fun-pointer-lowtag)
194             lexenv-tn nl0)
195   (inst addi (- (* simple-fun-code-offset n-word-bytes)
196                 fun-pointer-lowtag)
197         nl0 lip)
198   (inst bv lip :nullify t))
199
200 (define-assembly-routine
201   (funcallable-instance-tramp (:return-style :none))
202   nil
203   (inst nop)
204   (inst nop)
205   (inst nop)
206   (inst nop)
207   (inst nop)
208   (inst ldw 3 lexenv-tn lexenv-tn)
209   (inst ldw (- (* closure-fun-slot n-word-bytes)
210                   fun-pointer-lowtag)
211             lexenv-tn code-tn)
212   (inst addi (- (* simple-fun-code-offset n-word-bytes)
213                 fun-pointer-lowtag) code-tn lip-tn)
214   (inst bv lip-tn :nullify t))
215
216 #!+hpux
217 (define-assembly-routine
218   (return-from-lisp-stub (:return-style :none))
219   ((:temp lip interior-reg lip-offset)
220    (:temp nl0 descriptor-reg nl0-offset)
221    (:temp nl1 descriptor-reg nl1-offset)
222    (:temp lra descriptor-reg lra-offset))
223   ; before calling into lisp we must save our return address (reg_LRA)
224   (store-symbol-value lra *c-lra*)
225   ; note the lra we calculate next must "simulate" an fixnum,
226   ; because compute-calling-frame will use fixnump on this value.
227   ; either use 16 or 20, finetune it...
228   (inst addi 19 nl0 lra) ; then setup the new LRA (rest of this routine after branch)
229   (inst bv lip :nullify t)
230   (inst word return-pc-header-widetag)
231   ; ok, we are back from the lisp-call, lets return to c
232   ; FIX-lav: steal more stuff from call_into_lisp here, ideally the whole thing
233   (inst move ocfp-tn csp-tn) ; dont think we should ever get here
234   (inst nop)
235   (load-symbol-value nl0 *c-lra*)
236   (inst addi 1 nl0 nl0)
237   (inst ble 0 c-text-space nl0 :nullify t))