Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / src / assembly / x86 / assem-rtns.lisp
1 ;;;; the machine specific support routines needed by the file assembler
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 \f
14 ;;;; RETURN-MULTIPLE
15
16 ;;; For RETURN-MULTIPLE, we have to move the results from the end of
17 ;;; the frame for the function that is returning to the end of the
18 ;;; frame for the function being returned to.
19
20 #+sb-assembling ;; We don't want a vop for this one.
21 (define-assembly-routine
22     (return-multiple (:return-style :none))
23     (;; These are really arguments.
24      (:temp ecx unsigned-reg ecx-offset)
25      (:temp esi unsigned-reg esi-offset)
26
27      ;; These we need as temporaries.
28      (:temp eax unsigned-reg eax-offset)
29      (:temp ebx unsigned-reg ebx-offset)
30      (:temp edx unsigned-reg edx-offset)
31      (:temp edi unsigned-reg edi-offset))
32
33   ;; Pick off the cases where everything fits in register args.
34   (inst jecxz ZERO-VALUES)
35   (inst cmp ecx (fixnumize 1))
36   (inst jmp :e ONE-VALUE)
37   (inst cmp ecx (fixnumize 2))
38   (inst jmp :e TWO-VALUES)
39   (inst cmp ecx (fixnumize 3))
40   (inst jmp :e THREE-VALUES)
41
42   ;; As per the calling convention EBX is expected to point at the SP
43   ;; before the stack frame.
44   (inst lea ebx (make-ea :dword :base ebp-tn
45                          :disp (* sp->fp-offset n-word-bytes)))
46
47   ;; Save the count, the return address and restore the frame pointer,
48   ;; because the loop is going to destroy them.
49   (inst mov edx ecx)
50   (inst mov eax (make-ea :dword :base ebp-tn
51                          :disp (frame-byte-offset return-pc-save-offset)))
52   (inst mov ebp-tn (make-ea :dword :base ebp-tn
53                             :disp (frame-byte-offset ocfp-save-offset)))
54   ;; Blit the values down the stack. Note: there might be overlap, so
55   ;; we have to be careful not to clobber values before we've read
56   ;; them. Because the stack builds down, we are copying to a larger
57   ;; address. Therefore, we need to iterate from larger addresses to
58   ;; smaller addresses. pfw-this says copy ecx words from esi to edi
59   ;; counting down.
60   (inst shr ecx (1- n-lowtag-bits))
61   (inst std)                            ; count down
62   (inst sub esi n-word-bytes)
63   (inst lea edi (make-ea :dword :base ebx :disp (- n-word-bytes)))
64   (inst rep)
65   (inst movs :dword)
66   (inst cld)
67
68   ;; Restore the count.
69   (inst mov ecx edx)
70
71   ;; Set the stack top to the last result.
72   (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes))
73
74   ;; Load the register args.
75   (loadw edx ebx -1)
76   (loadw edi ebx -2)
77   (loadw esi ebx -3)
78
79   ;; And back we go.
80   (inst stc)
81   (inst push eax)
82   (inst ret)
83
84   ;; Handle the register arg cases.
85   ZERO-VALUES
86   (inst lea ebx (make-ea :dword :base ebp-tn
87                          :disp (* sp->fp-offset n-word-bytes)))
88   (inst mov edx nil-value)
89   (inst mov edi edx)
90   (inst mov esi edx)
91   (inst mov esp-tn ebp-tn)
92   (inst stc)
93   (inst pop ebp-tn)
94   (inst ret)
95
96   ;; Note: we can get this, because the return-multiple vop doesn't
97   ;; check for this case when size > speed.
98   ONE-VALUE
99   (loadw edx esi -1)
100   (inst mov esp-tn ebp-tn)
101   (inst clc)
102   (inst pop ebp-tn)
103   (inst ret)
104
105   TWO-VALUES
106   (inst lea ebx (make-ea :dword :base ebp-tn
107                          :disp (* sp->fp-offset n-word-bytes)))
108   (loadw edx esi -1)
109   (loadw edi esi -2)
110   (inst mov esi nil-value)
111   (inst mov esp-tn ebp-tn)
112   (inst stc)
113   (inst pop ebp-tn)
114   (inst ret)
115
116   THREE-VALUES
117   (inst lea ebx (make-ea :dword :base ebp-tn
118                          :disp (* sp->fp-offset n-word-bytes)))
119   (loadw edx esi -1)
120   (loadw edi esi -2)
121   (loadw esi esi -3)
122   (inst mov esp-tn ebp-tn)
123   (inst stc)
124   (inst pop ebp-tn)
125   (inst ret))
126 \f
127 ;;;; TAIL-CALL-VARIABLE
128
129 ;;; For tail-call-variable, we have to copy the arguments from the end
130 ;;; of our stack frame (were args are produced) to the start of our
131 ;;; stack frame (were args are expected).
132 ;;;
133 ;;; We take the function to call in EAX and a pointer to the arguments in
134 ;;; ESI. EBP says the same over the jump, and the old frame pointer is
135 ;;; still saved in the first stack slot. The return-pc is saved in
136 ;;; the second stack slot, so we have to push it to make it look like
137 ;;; we actually called. We also have to compute ECX from the difference
138 ;;; between ESI and the stack top.
139 #+sb-assembling ;; No vop for this one either.
140 (define-assembly-routine
141     (tail-call-variable
142      (:return-style :none))
143
144     ((:temp eax unsigned-reg eax-offset)
145      (:temp ebx unsigned-reg ebx-offset)
146      (:temp ecx unsigned-reg ecx-offset)
147      (:temp edx unsigned-reg edx-offset)
148      (:temp edi unsigned-reg edi-offset)
149      (:temp esi unsigned-reg esi-offset))
150
151   ;; Calculate NARGS (as a fixnum)
152   (move ecx esi)
153   (inst sub ecx esp-tn)
154
155   ;; Check for all the args fitting the registers.
156   (inst cmp ecx (fixnumize 3))
157   (inst jmp :le REGISTER-ARGS)
158
159   ;; Save the OLD-FP and RETURN-PC because the blit is going to trash
160   ;; those stack locations. Save the ECX, because the loop is going to
161   ;; trash it.
162   (pushw ebp-tn (frame-word-offset ocfp-save-offset))
163   (loadw ebx ebp-tn (frame-word-offset return-pc-save-offset))
164   (inst push ecx)
165
166   ;; Do the blit. Because we are coping from smaller addresses to
167   ;; larger addresses, we have to start at the largest pair and work
168   ;; our way down.
169   (inst shr ecx (1- n-lowtag-bits))
170   (inst std)                            ; count down
171   (inst lea edi (make-ea :dword :base ebp-tn :disp (frame-byte-offset 0)))
172   (inst sub esi (fixnumize 1))
173   (inst rep)
174   (inst movs :dword)
175   (inst cld)
176
177   ;; Load the register arguments carefully.
178   (loadw edx ebp-tn (frame-word-offset ocfp-save-offset))
179
180   ;; Restore OLD-FP and ECX.
181   (inst pop ecx)
182   ;; Overwrites a1
183   (popw ebp-tn (frame-word-offset ocfp-save-offset))
184
185   ;; Blow off the stack above the arguments.
186   (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes))
187
188   ;; remaining register args
189   (inst mov edi edx)
190   (loadw edx ebp-tn (frame-word-offset 0))
191   (loadw esi ebp-tn (frame-word-offset 2))
192
193   ;; Push the (saved) return-pc so it looks like we just called.
194   (inst push ebx)
195
196   ;; And jump into the function.
197   (inst jmp (make-ea-for-object-slot eax closure-fun-slot fun-pointer-lowtag))
198
199   ;; All the arguments fit in registers, so load them.
200   REGISTER-ARGS
201   (loadw edx esi -1)
202   (loadw edi esi -2)
203   (loadw esi esi -3)
204
205   ;; Clear most of the stack.
206   (inst lea esp-tn
207         (make-ea :dword :base ebp-tn :disp (* (- sp->fp-offset 3) n-word-bytes)))
208
209   ;; Push the return-pc so it looks like we just called.
210   (pushw ebp-tn (frame-word-offset return-pc-save-offset))
211
212   ;; And away we go.
213   (inst jmp (make-ea-for-object-slot eax closure-fun-slot fun-pointer-lowtag)))
214 \f
215 (define-assembly-routine (throw
216                           (:return-style :raw))
217                          ((:arg target (descriptor-reg any-reg) edx-offset)
218                           (:arg start any-reg ebx-offset)
219                           (:arg count any-reg ecx-offset)
220                           (:temp catch any-reg eax-offset))
221
222   (declare (ignore start count))
223
224   (load-tl-symbol-value catch *current-catch-block*)
225
226   LOOP
227
228   (let ((error (gen-label)))
229     (assemble (*elsewhere*)
230       (emit-label error)
231
232       ;; Fake up a stack frame so that backtraces come out right.
233       (inst push ebp-tn)
234       (inst mov ebp-tn esp-tn)
235
236       (emit-error-break nil error-trap
237                         (error-number-or-lose 'unseen-throw-tag-error)
238                         (list target)))
239     (inst test catch catch)             ; check for NULL pointer
240     (inst jmp :z error))
241
242   (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0))
243   (inst jmp :e EXIT)
244
245   (loadw catch catch catch-block-previous-catch-slot)
246   (inst jmp LOOP)
247
248   EXIT
249
250   ;; Here EAX points to catch block containing symbol pointed to by EDX.
251   (inst jmp (make-fixup 'unwind :assembly-routine)))
252
253 ;;;; non-local exit noise
254
255 #!-win32
256 (define-assembly-routine (unwind
257                           (:return-style :none)
258                           (:translate %continue-unwind)
259                           (:policy :fast-safe))
260                          ((:arg block (any-reg descriptor-reg) eax-offset)
261                           (:arg start (any-reg descriptor-reg) ebx-offset)
262                           (:arg count (any-reg descriptor-reg) ecx-offset)
263                           (:temp uwp unsigned-reg esi-offset))
264   (declare (ignore start count))
265
266   (let ((error (generate-error-code nil 'invalid-unwind-error)))
267     (inst test block block)             ; check for NULL pointer
268     (inst jmp :z error))
269
270   (load-tl-symbol-value uwp *current-unwind-protect-block*)
271
272   ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in
273   ;; argument's CURRENT-UWP-SLOT?
274   (inst cmp uwp
275         (make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
276   ;; If a match, return to context in arg block.
277   (inst jmp :e DO-EXIT)
278
279   ;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context.
280   ;; Important! Must save (and return) the arg 'block' for later use!!
281   (move edx-tn block)
282   (move block uwp)
283   ;; Set next unwind protect context.
284   (loadw uwp uwp unwind-block-current-uwp-slot)
285   ;; we're about to reload ebp anyway, so let's borrow it here as a
286   ;; temporary.  Hope this works
287   (store-tl-symbol-value uwp *current-unwind-protect-block* ebp-tn)
288
289   DO-EXIT
290
291   (loadw ebp-tn block unwind-block-current-cont-slot)
292
293   ;; Uwp-entry expects some things in known locations so that they can
294   ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and
295   ;; count in ecx-tn.
296
297   (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0)))
298
299
300 ;;;; Win32 non-local exit noise
301
302 #!+win32
303 (define-assembly-routine (unwind
304                           (:return-style :none)
305                           (:policy :fast-safe))
306                          ((:arg block (any-reg descriptor-reg) eax-offset)
307                           (:arg start (any-reg descriptor-reg) ebx-offset)
308                           (:arg count (any-reg descriptor-reg) ecx-offset))
309   (declare (ignore start count))
310
311   (let ((error (generate-error-code nil 'invalid-unwind-error)))
312     (inst test block block)             ; check for NULL pointer
313     (inst jmp :z error))
314
315   ;; Save all our registers, as we're about to clobber them.
316   (inst pusha)
317
318   ;; Find the SEH frame surrounding our target.
319   (loadw ecx-tn block unwind-block-next-seh-frame-slot)
320
321   ;; This section copied from VOP CALL-OUT.
322   ;; Setup the NPX for C; all the FP registers need to be
323   ;; empty; pop them all.
324   (dotimes (i 8)
325     (inst fstp fr0-tn))
326
327   ;; I'm unlikely to ever forget this again.
328   (inst cld)
329
330   ;; Set up a bogus stack frame for RtlUnwind to pick its return
331   ;; address from.  (Yes, this is how RtlUnwind works.)
332   (inst push (make-fixup 'win32-unwind-tail :assembly-routine))
333   (inst push ebp-tn)
334   (inst mov ebp-tn esp-tn)
335
336   ;; Actually call out for the unwind.
337   (inst push 0)
338   (inst push 0)
339   (inst push 0)
340   (inst push ecx-tn)
341   (inst call (make-fixup "RtlUnwind" :foreign)))
342
343 ;; We want no VOP for this one and for it to only happen on Win32
344 ;; targets.  Hence the following disaster.
345 #!+#.(cl:if (cl:member sb-assembling cl:*features*) win32 '(or))
346 (define-assembly-routine
347     (win32-unwind-tail (:return-style :none))
348     ((:temp block unsigned-reg eax-offset))
349
350   ;; The unwind returns here.  Had to use a VOP for this because
351   ;; PUSH won't accept a label as an argument.
352
353   ;; Clean up the bogus stack frame we pushed for the unwind.
354   (inst pop ebp-tn)
355   (inst pop esi-tn) ;; Random scratch register.
356
357   ;; This section based on VOP CALL-OUT.
358   ;; Restore the NPX for lisp; ensure no regs are empty
359   (dotimes (i 8)
360     (inst fldz))
361
362   ;; Restore our regs.
363   (inst popa)
364
365   ;; By now we've unwound all the UWP frames required, so we
366   ;; just jump to our target block.
367   (loadw ebp-tn block unwind-block-current-cont-slot)
368
369   ;; Nlx-entry expects the arg start in ebx-tn and the arg count
370   ;; in ecx-tn.  Fortunately, that's where they are already.
371   (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0)))
372
373
374 ;;;; Win32 UWP block SEH interface.
375
376 ;; We want no VOP for this one and for it to only happen on Win32
377 ;; targets.  Hence the following disaster.
378 #!+#.(cl:if (cl:member sb-assembling cl:*features*) win32 '(or))
379 (define-assembly-routine
380     (uwp-seh-handler (:return-style :none))
381     ((:temp block unsigned-reg eax-offset))
382
383   ;; We get called for any exception which happens within our
384   ;; dynamic contour that isn't handled below us, and for
385   ;; unwinding.
386
387   ;; For the exceptions we just return ExceptionContinueSearch.
388
389   ;; Find the exception record.
390   (inst mov eax-tn (make-ea :dword :base esp-tn :disp 4))
391
392   ;; Check unwind flags.
393   (inst test (make-ea :byte :base eax-tn :disp 4) 6) ; EH_UNWINDING | EH_EXIT_UNWIND
394
395   ;; To see if we're unwinding or not.
396   (inst jmp :nz UNWINDING)
397
398   ;; We're not unwinding, so we're not interested.
399   (inst mov eax-tn 1) ;; exception-continue-search
400   (inst ret)
401
402   ;; For the unwinds we establish a basic environment as per
403   ;; call_into_lisp, but without the extra SEH frame (the theory
404   ;; being that we're already in a Lisp SEH context), and invoke
405   ;; our UWP block to unwind itself.
406
407   ;; FIXME: Do we need to establish an SEH frame anyway?  And do
408   ;; we need to do the same stack frame hackery for the debugger
409   ;; as we do for the main exception handler?
410
411   ;; When the UWP block calls %continue-unwind, we come back to
412   ;; the next assembly routine, below, which reinitializes for C
413   ;; and returns to the Win32 unwind machinery.
414
415   ;; If the UWP block sees fit to do a non-local exit, things
416   ;; Just Work, thanks to the Win32 API being sanely designed
417   ;; and our complying with it.
418
419   ;; We also must update *current-unwind-protect-block* before
420   ;; calling the cleanup function.
421
422   UNWINDING
423
424   ;; Save all registers (overkill)
425   (inst pusha)
426
427   ;; Establish our stack frame.
428   (inst mov ebp-tn esp-tn)
429
430   ;; This section based on VOP CALL-OUT.
431   ;; Restore the NPX for lisp; ensure no regs are empty
432   (dotimes (i 8)
433     (inst fldz))
434
435   ;; Find our unwind-block by way of our SEH frame.
436   (inst mov block (make-ea :dword :base ebp-tn :disp #x28))
437   (inst lea block (make-ea :dword :base block
438                            :disp (- (* unwind-block-next-seh-frame-slot
439                                        n-word-bytes))))
440
441   ;; Update *CURRENT-UNWIND-PROTECT-BLOCK*.
442   (loadw ebx-tn block unwind-block-current-uwp-slot)
443   (store-tl-symbol-value ebx-tn *current-unwind-protect-block* ecx-tn)
444
445   ;; Uwp-entry expects some things in known locations so that they can
446   ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and
447   ;; count in ecx-tn.  We don't actually have any of that here, but we
448   ;; do need to have access to our own stack frame, so we hijack the
449   ;; known locations to cover our own state.
450
451   (inst xor ebx-tn ebx-tn)
452   (inst xor ecx-tn ecx-tn)
453   (inst mov ebx-tn ebp-tn)
454   (loadw ebp-tn block unwind-block-current-cont-slot)
455   (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0)))
456
457 #!+win32
458 (define-assembly-routine (continue-unwind
459                           (:return-style :none)
460                           (:translate %continue-unwind)
461                           (:policy :fast-safe))
462                          ((:arg block (any-reg descriptor-reg) eax-offset)
463                           (:arg start (any-reg descriptor-reg) ebx-offset)
464                           (:arg count (any-reg descriptor-reg) ecx-offset))
465   (declare (ignore block count))
466   ;; The args here are mostly ignored because we're using the
467   ;; win32 unwind mechanism and keep all that elsewhere.  The
468   ;; exception is START, which we use to pass the saved EBP for
469   ;; our exception handler.
470
471   ;; "All" we have to do here is reload our EBP, reestablish a C
472   ;; environment, and return ExceptionContinueSearch.  The OS
473   ;; handles the rest.
474
475   ;; Restore our frame pointer.
476   (inst mov esp-tn start)
477
478   ;; This section copied from VOP CALL-OUT.
479   ;; Setup the NPX for C; all the FP registers need to be
480   ;; empty; pop them all.
481   (dotimes (i 8)
482     (inst fstp fr0-tn))
483
484   ;; I'm unlikely to ever forget this again.
485   (inst cld)
486
487   ;; Restore our saved registers
488   (inst popa)
489
490   ;; And we're done.
491   (inst mov eax-tn 1) ;; exception-continue-search
492   (inst ret))